packages feed

quickcheck-state-machine 0.8.0 → 0.9.0

raw patch · 41 files changed

+1397/−1191 lines, 41 filesdep −aesondep −generic-datadep −persistent-templatedep ~QuickCheckdep ~ansi-wl-pprintdep ~base

Dependencies removed: aeson, generic-data, persistent-template, servant, wai

Dependency ranges changed: QuickCheck, ansi-wl-pprint, base, bytestring, containers, filepath, process, sop-core, text, time

Files

CHANGELOG.md view
@@ -1,3 +1,13 @@+#### 0.9.0 (2024-01-16)++* Split the package into the machinery that abstracts over whichever diffing+  implementation is in use (via the `CanDiff` class), and the implementation of+  that class via the vendored tree-diff. See the+  [README](https://github.com/stevana/quickcheck-state-machine#using-quickcheck-state-machine-as-a-dependency)+  for more details on how to depend on either.++* Support building with ghc-9.8.1.+ #### 0.8.0 (2023-11-17)  * BREAKING CHANGE: Remove `markov-chain-usage-model` dependency and the related
CONTRIBUTING.md view
@@ -1,14 +1,11 @@ ## Contributing -### Release checklist+Contributions are most welcome! +Please open an issue before embarking on a big change. Before you open a PR,+try to:+   1. Update CHANGELOG.md;-  2. Bump version in .cabal file and fix bounds;-  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;-  6. Git tag the version: `git tag -a v$VERSION -m "Tag v$VERISON" && git push-     origin v$VERSION`.+  2. Add `@since $VERSION`, if appropriate;+  3. Update CI in `.github/workflows/main.yaml` if, for example, new GHC support+     is added.
LICENSE view
@@ -1,7 +1,7 @@-Copyright (c) 2017-2023 Stevan Andjelkovic, Daniel Gustafsson, Jacob Stanley,+Copyright (c) 2017-2024 Stevan Andjelkovic, Daniel Gustafsson, Jacob Stanley,                         Xia Li-yao, Robert Danitz, Thomas Winant, Edsko de                         Vries, Momoko Hattori, Kostas Dermentzis, Adam Boniecki,-                        Javier Sagredo, Oleg Grenrus+                        Javier Sagredo, Oleg Grenrus, Erik de Castro Lopo  All rights reserved.
README.md view
@@ -667,6 +667,43 @@     [tests](https://github.com/stevana/raft/blob/master/test/QuickCheckStateMachine.hs)     combined with fault injection (node and network failures). +### Using `quickcheck-state-machine` as a dependency++In order to bring `quickcheck-state-machine` into your code, add it to the+`build-depends` section in your cabal file:++``` cabal+test-suite ...+  build-depends:+    , quickcheck-state-machine+```++This dependency can be used out of the box, however, it comes with an fork of an+old version of+[`tree-diff`](https://hackage.haskell.org/package/tree-diff-0.0.2.1) vendored+inside.++> For `quickcheck-state-machine` to remain BSD-style licensed, it could not+> depend on the `tree-diff` package as that one changed its license to `GPL`,+> therefore the solution was to vendor an older BSD-style licensed version of+> it. Using this vendored version, your code regardless of whether it is testing+> code or not, can remain BSD-style licensed.++In case you want to make use of the upstream `tree-diff` package, you can depend+on a slightly different library name:++``` cabal+test-suite ...+  build-depends:+    , quickcheck-state-machine:no-vendored-treediff+```++For this to compile properly, you will have to provide your own machinery to+implement the `CanDiff` class with the upstream `tree-diff` definitions. You+will have to implement something very similar to [this+module](./tree-diff/Test/StateMachine/TreeDiff/Diffing.hs) (which is doing+exactly this but with an old `tree-diff` version).+ ### How to contribute  The `quickcheck-state-machine` library is still very experimental.
quickcheck-state-machine.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            quickcheck-state-machine-version:         0.8.0+version:         0.9.0 synopsis:        Test monadic programs using state machine based models description:   See README at <https://github.com/stevana/quickcheck-state-machine#readme>@@ -13,7 +13,7 @@ copyright:   Copyright (C) 2017-2018, ATS Advanced Telematic Systems GmbH;   2018-2019, HERE Europe B.V.;-  2019-2023, Stevan Andjelkovic.+  2019-2024, Stevan Andjelkovic.  category:        Testing build-type:      Simple@@ -22,15 +22,24 @@   CONTRIBUTING.md   README.md -tested-with:     GHC ==8.8.4 || ==8.10.7 || ==9.2.8 || ==9.4.7 || ==9.6.3+tested-with:+  GHC ==8.8.4 || ==8.10.7 || ==9.2.8 || ==9.4.7 || ==9.6.3 || ==9.8.1 -library+-- Due to `tree-diff` being `GPL`, this library makes use of an interface+-- (@CanDiff@) to diff models. This can be implemented with the vendored+-- tree-diff or with the upstream one, but we only provide the former in the+-- main library of the package below. See+-- https://github.com/stevana/quickcheck-state-machine#readme for how to depend+-- on either version.+library no-vendored-treediff+  visibility:       public   hs-source-dirs:   src   ghc-options:      -Wall   exposed-modules:     Test.StateMachine     Test.StateMachine.BoxDrawer     Test.StateMachine.ConstructorName+    Test.StateMachine.Diffing     Test.StateMachine.DotDrawing     Test.StateMachine.Labelling     Test.StateMachine.Lockstep.Auxiliary@@ -39,12 +48,6 @@     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@@ -54,25 +57,20 @@     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:     , base        >=4.10    && <5-    , containers  >=0.5.7.1 && <0.7+    , containers  >=0.5.7.1 && <0.8     , directory   >=1.0.0.0 && <1.4     , exceptions  >=0.8.3   && <0.11-    , filepath    >=1.0     && <1.5+    , filepath    >=1.0     && <1.6     , mtl         >=2.2.1   && <2.4-    , process     >=1.2.0.0 && <1.7-    , text        >=1.2.3.1 && <2.1+    , text        >=1.2.3.1 && <2.2     , time        >=1.7     && <1.13    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@@ -81,23 +79,72 @@     , split           >=0.2.3.5     && <0.3     , unliftio        >=0.2.7.0     && <0.3 +  default-language: Haskell2010++library+  hs-source-dirs:     tree-diff+  ghc-options:        -Wall+  exposed-modules:+    Test.StateMachine.TreeDiff+    Test.StateMachine.TreeDiff.Class+    Test.StateMachine.TreeDiff.Diffing+    Test.StateMachine.TreeDiff.Expr+    Test.StateMachine.TreeDiff.List+    Test.StateMachine.TreeDiff.Pretty+    Test.StateMachine.TreeDiff.Tree++  reexported-modules:+    Test.StateMachine,+    Test.StateMachine.BoxDrawer,+    Test.StateMachine.ConstructorName,+    Test.StateMachine.Diffing,+    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.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++  -- GHC boot library dependencies:+  -- (https://gitlab.haskell.org/ghc/ghc/-/blob/master/packages)+  build-depends:+    , base+    , containers+    , text+    , time++  build-depends:+    , ansi-wl-pprint+    , QuickCheck+    , sop-core+   -- 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+    , base-compat                                    >=0.9.3    && <0.14+    , bytestring                                     >=0.10.4.0 && <0.13+    , generics-sop                                   >=0.3.1.0  && <0.6+    , MemoTrie                                       >=0.6.8    && <0.7+    , pretty                                         >=1.1.1.1  && <1.2+    , quickcheck-state-machine:no-vendored-treediff+    , vector                                         >=0.12.0.1 && <0.14 -  default-language: Haskell2010+  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@@ -116,7 +163,6 @@     , 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@@ -126,7 +172,6 @@     , 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@@ -140,7 +185,6 @@     , 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:
src/Test/StateMachine.hs view
@@ -70,19 +70,16 @@    , module Test.StateMachine.Logic -    -- * Re-export-  , ToExpr-  , toExpr-+  -- * Diffing class+  , CanDiff (..)   ) where  import           Prelude                    ()  import           Test.StateMachine.ConstructorName+import           Test.StateMachine.Diffing import           Test.StateMachine.Logic import           Test.StateMachine.Parallel import           Test.StateMachine.Sequential-import           Test.StateMachine.TreeDiff-                   (ToExpr, toExpr) import           Test.StateMachine.Types
+ src/Test/StateMachine/Diffing.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances   #-}++-- | Class that will be used when diffing values. It ought to be instantiated+-- with our vendored @tree-diff@ (see "Test.StateMachine.Diffing.TreeDiff"), or+-- other akin implementations.++module Test.StateMachine.Diffing (CanDiff(..), ediff) where++import           Data.Proxy+                   (Proxy(..))+import qualified Text.PrettyPrint.ANSI.Leijen as WL++class CanDiff x where+  -- | Expressions that will be diffed+  type AnExpr x+  -- | What will the diff of two @AnExpr@s result in+  type ADiff x++  -- | Extract the expression from the data+  toDiff :: x -> AnExpr x++  -- | Diff two expressions+  exprDiff :: Proxy x -> AnExpr x -> AnExpr x -> ADiff x++  -- | Output a diff in compact form+  diffToDocCompact :: Proxy x -> ADiff x -> WL.Doc++  -- | Output a diff+  diffToDoc :: Proxy x -> ADiff x -> WL.Doc++  -- | Output an expression+  exprToDoc :: Proxy x -> AnExpr x -> WL.Doc++ediff :: forall x. CanDiff x => x -> x -> ADiff x+ediff x y = exprDiff (Proxy @x) (toDiff x) (toDiff y)
src/Test/StateMachine/Lockstep/NAry.hs view
@@ -22,7 +22,7 @@   , Cmd   , Resp   , RealHandles-  , MockHandle+  , MockHandleN   , Test   , Tag     -- * Test term-level parameters@@ -71,7 +71,6 @@ import qualified Test.StateMachine.Types.Rank2        as Rank2  import           Test.StateMachine.Lockstep.Auxiliary-import qualified Test.StateMachine.TreeDiff           as TD  {-------------------------------------------------------------------------------   Test type-level parameters@@ -94,8 +93,8 @@  -- | Mock handles ----- For each real handle @a@, @MockHandle t a@ is the corresponding mock handle.-data family MockHandle t a :: Type+-- For each real handle @a@, @MockHandleN t a@ is the corresponding mock handle.+data family MockHandleN t a :: Type  -- | Commands --@@ -103,7 +102,7 @@ -- functor applied to each of them. Two typical instantiations are -- -- > Cmd t I              (RealHandles t)   -- for the system under test--- > Cmd t (MockHandle t) (RealHandles t)   -- for the mock+-- > Cmd t (MockHandleN t) (RealHandles t)   -- for the mock data family Cmd t :: (Type -> Type) -> [Type] -> Type  -- | Responses@@ -111,7 +110,7 @@ -- The type arguments are similar to those of @Cmd@. Two typical instances: -- -- > Resp t I              (RealHandles t)  -- for the system under test--- > Resp t (MockHandle t) (RealHandles t)  -- for the mock+-- > Resp t (MockHandleN t) (RealHandles t)  -- for the mock data family Resp t :: (Type -> Type) -> [Type] -> Type  -- | Tags@@ -126,43 +125,28 @@ -------------------------------------------------------------------------------}  -- | Relation between real and mock references for single handle type @a@-newtype Refs t r a = Refs { unRefs :: [(Reference a r, MockHandle t a)] }+newtype Refs t r a = Refs { unRefs :: [(Reference a r, MockHandleN t a)] }   deriving newtype (Semigroup, Monoid, Generic)  deriving   stock-  instance (Show1 r, Show a, Show (MockHandle t a)) => Show (Refs t r a)--deriving-  newtype-  instance (ToExpr a, ToExpr (MockHandle t a)) => ToExpr (Refs t Concrete a)+  instance (Show1 r, Show a, Show (MockHandleN t a)) => Show (Refs t r a)  -- | Relation between real and mock references for /all/ handle types newtype Refss t r = Refss { unRefss :: NP (Refs t r) (RealHandles t) }  instance ( Show1 r-         , All (And Show (Compose Show (MockHandle t))) (RealHandles t)+         , All (And Show (Compose Show (MockHandleN t))) (RealHandles t)          ) => Show (Refss t r) where   show = unlines        . hcollapse-       . hcmap (Proxy @(And Show (Compose Show (MockHandle t)))) showOne+       . hcmap (Proxy @(And Show (Compose Show (MockHandleN t)))) showOne        . unRefss     where-      showOne :: (Show a, Show (MockHandle t a))+      showOne :: (Show a, Show (MockHandleN t a))               => Refs t r a -> K String a       showOne = K . show -instance All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)-      => ToExpr (Refss t Concrete) where-  toExpr = TD.Lst-         . hcollapse-         . hcmap (Proxy @(And ToExpr (Compose ToExpr (MockHandle t)))) toExprOne-         . unRefss-    where-      toExprOne :: (ToExpr a, ToExpr (MockHandle t a))-                => Refs t Concrete a -> K TD.Expr a-      toExprOne = K . toExpr- instance SListI (RealHandles t) => Semigroup (Refss t r) where   Refss rss <> Refss rss' = Refss $ hzipWith (<>) rss rss' @@ -201,13 +185,9 @@  deriving stock instance ( Show1 r                         , Show (MockState t)-                        , All (And Show (Compose Show (MockHandle t))) (RealHandles t)+                        , All (And Show (Compose Show (MockHandleN t))) (RealHandles t)                         ) => Show (Model t r) -instance ( ToExpr (MockState t)-         , All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)-         ) => ToExpr (Model t Concrete)- initModel :: StateMachineTest t m -> Model t r initModel StateMachineTest{..} = Model initMock (Refss (hpure (Refs []))) @@ -222,14 +202,14 @@ data StateMachineTest t m =     ( Monad m     -- Requirements on the handles-    , All Typeable                                     (RealHandles t)-    , All Eq                                           (RealHandles t)-    , All (And Show   (Compose Show   (MockHandle t))) (RealHandles t)-    , All (And ToExpr (Compose ToExpr (MockHandle t))) (RealHandles t)+    , All Typeable                                       (RealHandles t)+    , All Eq                                             (RealHandles t)+    , All (And Show    (Compose Show    (MockHandleN t))) (RealHandles t)+    , All (And CanDiff (Compose CanDiff (MockHandleN t))) (RealHandles t)     -- Response     , NTraversable (Resp t)-    , Eq   (Resp t (MockHandle t)     (RealHandles t))-    , Show (Resp t (MockHandle t)     (RealHandles t))+    , Eq   (Resp t (MockHandleN t)     (RealHandles t))+    , Show (Resp t (MockHandleN t)     (RealHandles t))     , Show (Resp t (FlipRef Symbolic) (RealHandles t))     , Show (Resp t (FlipRef Concrete) (RealHandles t))     -- Command@@ -238,11 +218,13 @@     , Show (Cmd t (FlipRef Concrete) (RealHandles t))     -- MockState     , Show   (MockState t)-    , ToExpr (MockState t)+    , CanDiff (MockState t)     -- Tags     , Show (Tag t)+    -- Model+    , CanDiff (Model t Concrete)     ) => StateMachineTest {-      runMock    :: Cmd t (MockHandle t) (RealHandles t) -> MockState t -> (Resp t (MockHandle t) (RealHandles t), MockState t)+      runMock    :: Cmd t (MockHandleN t) (RealHandles t) -> MockState t -> (Resp t (MockHandleN t) (RealHandles t), MockState t)     , runReal    :: Cmd t I              (RealHandles t) -> m (Resp t I (RealHandles t))     , initMock   :: MockState t     , newHandles :: forall f. Resp t f (RealHandles t) -> NP ([] :.: f) (RealHandles t)@@ -288,30 +270,30 @@ -- > toMock :: Refss t Symbolic --          -> Cmd (FlipRef r) (Handles t) --          -> Cmd  ToMock     (Handles t)-toMockHandles :: (NTraversable f, t ~ Test f, All Eq (RealHandles t), Eq1 r)-              => Refss t r -> f :@ r -> f (MockHandle t) (RealHandles t)-toMockHandles rss (At fr) =+toMockHandleNs :: (NTraversable f, t ~ Test f, All Eq (RealHandles t), Eq1 r)+              => Refss t r -> f :@ r -> f (MockHandleN t) (RealHandles t)+toMockHandleNs rss (At fr) =     ncfmap (Proxy @Eq) (\pf -> find (unRefss rss) pf . unFlipRef) fr   where     find :: (Eq a, Eq1 r)          => NP (Refs t r) (RealHandles t)          -> Elem (RealHandles t) a-         -> Reference a r -> MockHandle t a+         -> Reference a r -> MockHandleN t a     find refss ix r = unRefs (npAt refss ix) ! r  step :: Eq1 r      => StateMachineTest t m      -> Model t r      -> Cmd t :@ r-     -> (Resp t (MockHandle t) (RealHandles t), MockState t)+     -> (Resp t (MockHandleN t) (RealHandles t), MockState t) step StateMachineTest{..} (Model st rss) cmd =-    runMock (toMockHandles rss cmd) st+    runMock (toMockHandleNs rss cmd) st  data Event t r = Event {       before   :: Model t    r     , cmd      :: Cmd   t :@ r     , after    :: Model t    r-    , mockResp :: Resp t (MockHandle t) (RealHandles t)+    , mockResp :: Resp t (MockHandleN t) (RealHandles t)     }  lockstep :: forall t m r. Eq1 r@@ -346,7 +328,7 @@               -> Resp  t :@ Concrete               -> Logic postcondition sm@StateMachineTest{} m c r =-    toMockHandles (modelRefss $ after e) r .== mockResp e+    toMockHandleNs (modelRefss $ after e) r .== mockResp e   where     e = lockstep sm m c r @@ -543,9 +525,9 @@  zipHandles :: SListI (RealHandles t)            => NP ([] :.: FlipRef r)    (RealHandles t)-           -> NP ([] :.: MockHandle t) (RealHandles t)+           -> NP ([] :.: MockHandleN t) (RealHandles t)            -> Refss t r zipHandles = \real mock -> Refss $ hzipWith zip' real mock   where-    zip' :: (:.:) [] (FlipRef r) a -> (:.:) [] (MockHandle t) a -> Refs t r a+    zip' :: (:.:) [] (FlipRef r) a -> (:.:) [] (MockHandleN t) a -> Refs t r a     zip' (Comp real) (Comp mock) = Refs $ zip (map unFlipRef real) mock
src/Test/StateMachine/Lockstep/Simple.hs view
@@ -33,6 +33,9 @@   , prop_parallel     -- * Translate to n-ary model model   , fromSimple+    -- * For orphan ToExpr instances+  , Simple+  , NAry.MockHandleN(SimpleToMock)   ) where  import           Data.Bifunctor@@ -144,7 +147,7 @@ cmdAtToSimple = At . fmap NAry.unFlipRef . unSimpleCmd . NAry.unAt  cmdMockToSimple :: Functor (Cmd t)-                => NAry.Cmd (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]+                => NAry.Cmd (Simple t) (NAry.MockHandleN (Simple t)) '[RealHandle t]                 -> Cmd t (MockHandle t) cmdMockToSimple = fmap unSimpleToMock . unSimpleCmd @@ -155,11 +158,11 @@  respMockFromSimple :: Functor (Resp t)                    => Resp t (MockHandle t)-                   -> NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]+                   -> NAry.Resp (Simple t) (NAry.MockHandleN (Simple t)) '[RealHandle t] respMockFromSimple = SimpleResp . fmap SimpleToMock  respMockToSimple :: Functor (Resp t)-                 => NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]+                 => NAry.Resp (Simple t) (NAry.MockHandleN (Simple t)) '[RealHandle t]                  -> Resp t (MockHandle t) respMockToSimple = fmap unSimpleToMock . unSimpleResp @@ -191,18 +194,21 @@     , Show (Cmd t (Reference (RealHandle t) Concrete))     , Traversable (Cmd t)       -- Real handles-    , Eq     (RealHandle t)-    , Show   (RealHandle t)-    , ToExpr (RealHandle t)+    , Eq      (RealHandle t)+    , Show    (RealHandle t)+    , CanDiff (RealHandle t)       -- Mock handles-    , Eq     (MockHandle t)-    , Show   (MockHandle t)-    , ToExpr (MockHandle t)+    , Eq      (MockHandle t)+    , Show    (MockHandle t)+    , CanDiff (MockHandle t)+    , CanDiff (NAry.MockHandleN (Simple t) (RealHandle t))       -- Mock state-    , Show   (MockState t)-    , ToExpr (MockState t)+    , Show    (MockState t)+    , CanDiff (MockState t)       -- Tags     , Show (Tag t)+      -- Model+    , CanDiff (NAry.Model (Simple t) Concrete)     ) => StateMachineTest {       runMock    :: Cmd t (MockHandle t) -> MockState t -> (Resp t (MockHandle t), MockState t)     , runReal    :: Cmd t (RealHandle t) -> IO (Resp t (RealHandle t))@@ -226,7 +232,7 @@ data instance NAry.Resp (Simple _) _f _hs where     SimpleResp :: Resp t (f h) -> NAry.Resp (Simple t) f '[h] -newtype instance NAry.MockHandle (Simple t) (RealHandle t) =+newtype instance NAry.MockHandleN (Simple t) (RealHandle t) =     SimpleToMock { unSimpleToMock :: MockHandle t }  unSimpleCmd :: NAry.Cmd (Simple t) f '[h] -> Cmd t (f h)@@ -238,12 +244,12 @@ instance ( Functor (Resp t)          , Eq (Resp t (MockHandle t))          , Eq (MockHandle t)-         ) => Eq (NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]) where+         ) => Eq (NAry.Resp (Simple t) (NAry.MockHandleN (Simple t)) '[RealHandle t]) where   SimpleResp r == SimpleResp r' = (unSimpleToMock <$> r) == (unSimpleToMock <$> r')  instance ( Functor (Resp t)          , Show (Resp t (MockHandle t))-         ) => Show (NAry.Resp (Simple t) (NAry.MockHandle (Simple t)) '[RealHandle t]) where+         ) => Show (NAry.Resp (Simple t) (NAry.MockHandleN (Simple t)) '[RealHandle t]) where   show (SimpleResp r) = show (unSimpleToMock <$> r)  instance ( Functor (Resp t)@@ -258,18 +264,14 @@          ) => Show (NAry.Cmd (Simple t) (NAry.FlipRef r) '[RealHandle t]) where   show (SimpleCmd r) = show (NAry.unFlipRef <$> r) -deriving stock instance Eq   (MockHandle t) => Eq   (NAry.MockHandle (Simple t) (RealHandle t))-deriving stock instance Show (MockHandle t) => Show (NAry.MockHandle (Simple t) (RealHandle t))+deriving stock instance Eq   (MockHandle t) => Eq   (NAry.MockHandleN (Simple t) (RealHandle t))+deriving stock instance Show (MockHandle t) => Show (NAry.MockHandleN (Simple t) (RealHandle t))  instance Traversable (Resp t) => NTraversable (NAry.Resp (Simple t)) where   nctraverse _ f (SimpleResp x) = SimpleResp <$> traverse (f ElemHead) x  instance Traversable (Cmd t) => NTraversable (NAry.Cmd (Simple t)) where   nctraverse _ f (SimpleCmd x) = SimpleCmd <$> traverse (f ElemHead) x--instance ToExpr (MockHandle t)-      => ToExpr (NAry.MockHandle (Simple t) (RealHandle t)) where-  toExpr (SimpleToMock h) = toExpr h  fromSimple :: StateMachineTest t -> NAry.StateMachineTest (Simple t) IO fromSimple StateMachineTest{..} = NAry.StateMachineTest {
src/Test/StateMachine/Sequential.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE BangPatterns          #-} {-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MonoLocalBinds        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeApplications      #-}  ----------------------------------------------------------------------------- -- |@@ -111,11 +113,11 @@                    (throwIO)  import           Test.StateMachine.ConstructorName+import           Test.StateMachine.Diffing+                   (CanDiff(..), ediff) 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@@ -462,10 +464,12 @@ getUsedConcrete :: Rank2.Foldable f => f Concrete -> [Dynamic] getUsedConcrete = Rank2.foldMap (\(Concrete x) -> [toDyn x]) -modelDiff :: ToExpr (model r) => model r -> Maybe (model r) -> Doc-modelDiff model = ansiWlBgEditExprCompact . flip ediff model . fromMaybe model+modelDiff :: forall model r. CanDiff (model r) => model r -> Maybe (model r) -> Doc+modelDiff model = diffToDocCompact p . flip ediff model . fromMaybe model+ where+   p = Proxy @(model r) -prettyPrintHistory :: forall model cmd m resp. ToExpr (model Concrete)+prettyPrintHistory :: forall model cmd m resp. CanDiff (model Concrete)                    => (Show (cmd Concrete), Show (resp Concrete))                    => StateMachine model cmd m resp                    -> History cmd resp@@ -510,7 +514,7 @@         ]     go _ _ _ = error "prettyPrintHistory: impossible." -prettyCommands :: (MonadIO m, ToExpr (model Concrete))+prettyCommands :: (MonadIO m, CanDiff (model Concrete))                => (Show (cmd Concrete), Show (resp Concrete))                => StateMachine model cmd m resp                -> History cmd resp@@ -518,8 +522,8 @@                -> PropertyM m () prettyCommands sm hist prop = prettyPrintHistory sm hist `whenFailM` prop -prettyPrintHistory' :: forall model cmd m resp tag. ToExpr (model Concrete)-                    => (Show (cmd Concrete), Show (resp Concrete), ToExpr tag)+prettyPrintHistory' :: forall model cmd m resp tag. CanDiff (model Concrete)+                    => (Show (cmd Concrete), Show (resp Concrete), CanDiff [tag])                     => StateMachine model cmd m resp                     -> ([Event model cmd resp Symbolic] -> [tag])                     -> Commands cmd resp@@ -532,7 +536,7 @@   . unHistory   where     tagsDiff :: [tag] -> [tag] -> Doc-    tagsDiff old new = ansiWlBgEditExprCompact (ediff old new)+    tagsDiff old new = diffToDocCompact (Proxy @[tag]) (ediff old new)      go :: model Concrete -> Maybe (model Concrete) -> [tag] -> [[tag]]        -> [Operation cmd resp] -> Doc@@ -577,7 +581,7 @@  -- | Variant of 'prettyCommands' that also prints the @tag@s covered by each -- command.-prettyCommands' :: (MonadIO m, ToExpr (model Concrete), ToExpr tag)+prettyCommands' :: (MonadIO m, CanDiff (model Concrete), CanDiff [tag])                 => (Show (cmd Concrete), Show (resp Concrete))                 => StateMachine model cmd m resp                 -> ([Event model cmd resp Symbolic] -> [tag])
− src/Test/StateMachine/TreeDiff.hs 
@@ -1,21 +0,0 @@--- | Diffing of (expression) trees.------ Diffing arbitrary Haskell data. First we convert values to untyped--- haskell-like expression 'Expr' using generically derivable 'ToExpr' class.--- Then we can diff two 'Expr' values.--- The conversion and diffing is done by 'ediff' function.--- See type and function haddocks for an examples.------ Interesting modules:------ * "Data.TreeDiff.Class" for a 'ToExpr' class and 'ediff' utility.----module Test.StateMachine.TreeDiff (-    module Test.StateMachine.TreeDiff.Expr,-    module Test.StateMachine.TreeDiff.Class,-    module Test.StateMachine.TreeDiff.Pretty,-    ) where--import Test.StateMachine.TreeDiff.Expr-import Test.StateMachine.TreeDiff.Class-import Test.StateMachine.TreeDiff.Pretty
− src/Test/StateMachine/TreeDiff/Class.hs 
@@ -1,481 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | A 'ToExpr' class.-module Test.StateMachine.TreeDiff.Class (-    ediff,-    ediff',-    ToExpr (..),-    defaultExprViaShow,-    -- * SOP-    sopToExpr,-    ) where--import Data.Foldable      (toList)-import Data.Proxy         (Proxy (..))-import Test.StateMachine.TreeDiff.Expr-import Data.List.Compat      (uncons)-import Generics.SOP-       (All, All2, ConstructorInfo (..), DatatypeInfo (..), FieldInfo (..),-       I (..), K (..), NP (..), SOP (..), constructorInfo, hcliftA2, hcmap,-       hcollapse, mapIK)-import Generics.SOP.GGP   (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom)-import GHC.Generics       (Generic)--import qualified Data.Map as Map---- Instances-import Control.Applicative   (Const (..), ZipList (..))-import Data.Fixed            (Fixed, HasResolution)-import Data.Functor.Identity (Identity (..))-import Data.Int-import Data.List.NonEmpty    (NonEmpty (..))-import Data.Void             (Void)-import Data.Word-import Numeric.Natural       (Natural)--import qualified Data.Monoid    as Mon-import qualified Data.Ratio     as Ratio-import qualified Data.Semigroup as Semi---- containers-import qualified Data.IntMap   as IntMap-import qualified Data.IntSet   as IntSet-import qualified Data.Sequence as Seq-import qualified Data.Set      as Set-import qualified Data.Tree     as Tree---- text-import qualified Data.Text      as T-import qualified Data.Text.Lazy as LT---- time-import qualified Data.Time as Time---- bytestring-import qualified Data.ByteString       as BS-import qualified Data.ByteString.Lazy  as LBS--- import qualified Data.ByteString.Short as SBS---- scientific--- import qualified Data.Scientific as Sci---- uuid-types--- import qualified Data.UUID.Types as UUID---- vector-import qualified Data.Vector           as V-import qualified Data.Vector.Primitive as VP-import qualified Data.Vector.Storable  as VS-import qualified Data.Vector.Unboxed   as VU---- tagged--- import Data.Tagged (Tagged (..))---- hashable--- import Data.Hashable (Hashed, unhashed)---- unordered-containers--- import qualified Data.HashMap.Strict as HM--- import qualified Data.HashSet        as HS---- aeson--- import qualified Data.Aeson as Aeson---- | Difference between two 'ToExpr' values.------ >>> let x = (1, Just 2) :: (Int, Maybe Int)--- >>> let y = (1, Nothing)--- >>> prettyEditExpr (ediff x y)--- _×_ 1 -(Just 2) +Nothing------ >>> data Foo = Foo { fooInt :: Either Char Int, fooBool :: [Maybe Bool], fooString :: String } deriving (Eq, Generic)--- >>> instance ToExpr Foo------ >>> prettyEditExpr $ ediff (Foo (Right 2) [Just True] "fo") (Foo (Right 3) [Just True] "fo")--- Foo {fooBool = [Just True], fooInt = Right -2 +3, fooString = "fo"}------ >>> prettyEditExpr $ ediff (Foo (Right 42) [Just True, Just False] "old") (Foo (Right 42) [Nothing, Just False, Just True] "new")--- Foo---   {fooBool = [-Just True, +Nothing, Just False, +Just True],---    fooInt = Right 42,---    fooString = -"old" +"new"}----ediff :: ToExpr a => a -> a -> Edit EditExpr-ediff x y = exprDiff (toExpr x) (toExpr y)---- | Compare different types.------ /Note:/ Use with care as you can end up comparing apples with oranges.------ >>> prettyEditExpr $ ediff' ["foo", "bar"] [Just "foo", Nothing]--- [-"foo", +Just "foo", -"bar", +Nothing]----ediff' :: (ToExpr a, ToExpr b) => a -> b -> Edit EditExpr-ediff' x y = exprDiff (toExpr x) (toExpr y)---- | 'toExpr' converts a Haskell value into--- untyped Haskell-like syntax tree, 'Expr'.------ >>> toExpr ((1, Just 2) :: (Int, Maybe Int))--- App "_\215_" [App "1" [],App "Just" [App "2" []]]----class ToExpr a where-    toExpr :: a -> Expr-    default toExpr-        :: (Generic a, All2 ToExpr (GCode a), GFrom a, GDatatypeInfo a)-        => a -> Expr-    toExpr x = sopToExpr (gdatatypeInfo (Proxy :: Proxy a)) (gfrom x)--    listToExpr :: [a] -> Expr-    listToExpr = Lst . map toExpr--instance ToExpr Expr where-    toExpr = id---- | An alternative implementation for literal types. We use 'show'--- representation of them.-defaultExprViaShow :: Show a => a -> Expr-defaultExprViaShow x = App (show x) []---- | >>> prettyExpr $ sopToExpr (gdatatypeInfo (Proxy :: Proxy String)) (gfrom "foo")--- _:_ 'f' "oo"-sopToExpr :: (All2 ToExpr xss) => DatatypeInfo xss -> SOP I xss -> Expr-sopToExpr di (SOP xss) = hcollapse $ hcliftA2-    (Proxy :: Proxy (All ToExpr))-    (\ci xs -> K (sopNPToExpr isNewtype ci xs))-    (constructorInfo di)-    xss-  where-    isNewtype = case di of-        Newtype {} -> True-        ADT {}     -> False--sopNPToExpr :: All ToExpr xs => Bool -> ConstructorInfo xs -> NP I xs -> Expr-sopNPToExpr _ (Infix cn _ _) xs = App ("_" ++ cn ++ "_") $ hcollapse $-    hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs-sopNPToExpr _ (Constructor cn) xs = App cn $ hcollapse $-    hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs-sopNPToExpr True (Record cn _) xs = App cn $ hcollapse $-    hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs-sopNPToExpr False (Record cn fi) xs = Rec cn $ Map.fromList $ hcollapse $-    hcliftA2 (Proxy :: Proxy ToExpr) mk fi xs-  where-    mk :: ToExpr x => FieldInfo x -> I x -> K (FieldName, Expr) x-    mk (FieldInfo fn) (I x) = K (fn, toExpr x)------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------instance ToExpr () where toExpr = defaultExprViaShow-instance ToExpr Bool where toExpr = defaultExprViaShow-instance ToExpr Ordering where toExpr = defaultExprViaShow--instance ToExpr Integer where toExpr = defaultExprViaShow-instance ToExpr Natural where toExpr = defaultExprViaShow--instance ToExpr Float where toExpr = defaultExprViaShow-instance ToExpr Double where toExpr = defaultExprViaShow--instance ToExpr Int where toExpr = defaultExprViaShow-instance ToExpr Int8 where toExpr = defaultExprViaShow-instance ToExpr Int16 where toExpr = defaultExprViaShow-instance ToExpr Int32 where toExpr = defaultExprViaShow-instance ToExpr Int64 where toExpr = defaultExprViaShow--instance ToExpr Word where toExpr = defaultExprViaShow-instance ToExpr Word8 where toExpr = defaultExprViaShow-instance ToExpr Word16 where toExpr = defaultExprViaShow-instance ToExpr Word32 where toExpr = defaultExprViaShow-instance ToExpr Word64 where toExpr = defaultExprViaShow--instance ToExpr (Proxy a) where toExpr = defaultExprViaShow---- | >>> prettyExpr $ toExpr 'a'--- 'a'------ >>> prettyExpr $ toExpr "Hello world"--- "Hello world"------ >>> prettyExpr $ toExpr "Hello\nworld"--- concat ["Hello\n", "world"]------ >>> traverse_ (print . prettyExpr . toExpr) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- concat ["foo\n", "bar"]--- concat ["foo\n", "bar\n"]----instance ToExpr Char where-    toExpr = defaultExprViaShow-    listToExpr = stringToExpr "concat" . unconcat uncons--stringToExpr-    :: Show a-    => String -- ^ name of concat-    -> [a]-    -> Expr-stringToExpr _  []  = App "\"\"" []-stringToExpr _  [l] = defaultExprViaShow l-stringToExpr cn ls  = App cn [Lst (map defaultExprViaShow ls)]---- | Split on '\n'.------ prop> \xs -> xs == concat (unconcat uncons xs)-unconcat :: forall a. (a -> Maybe (Char, a)) -> a -> [String]-unconcat uncons_ = go where-    go :: a -> [String]-    go xs = case span_ xs of-        ~(ys, zs)-            | null ys   -> []-            | otherwise -> ys : go zs--    span_ :: a -> (String, a)-    span_ xs = case uncons_ xs of-        Nothing         -> ("", xs)-        Just ~(x, xs')-            | x == '\n' -> ("\n", xs')-            | otherwise -> case span_ xs' of-            ~(ys, zs) -> (x : ys, zs)--instance ToExpr a => ToExpr (Maybe a) where-    toExpr Nothing  = App "Nothing" []-    toExpr (Just x) = App "Just" [toExpr x]--instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where-    toExpr (Left x)  = App "Left"  [toExpr x]-    toExpr (Right y) = App "Right" [toExpr y]--instance ToExpr a => ToExpr [a] where-    toExpr = listToExpr--instance (ToExpr a, ToExpr b) => ToExpr (a, b) where-    toExpr (a, b) = App "_×_" [toExpr a, toExpr b]-instance (ToExpr a, ToExpr b, ToExpr c) => ToExpr (a, b, c) where-    toExpr (a, b, c) = App "_×_×_" [toExpr a, toExpr b, toExpr c]-instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d) => ToExpr (a, b, c, d) where-    toExpr (a, b, c, d) = App "_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d]-instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e) => ToExpr (a, b, c, d, e) where-    toExpr (a, b, c, d, e) = App "_×_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d, toExpr e]---- | >>> prettyExpr $ toExpr (3 % 12 :: Rational)--- _%_ 1 4-instance (ToExpr a, Integral a) => ToExpr (Ratio.Ratio a) where-    toExpr r = App "_%_" [ toExpr $ Ratio.numerator r, toExpr $ Ratio.denominator r ]-instance HasResolution a => ToExpr (Fixed a) where toExpr = defaultExprViaShow---- | >>> prettyExpr $ toExpr $ Identity 'a'--- Identity 'a'-instance ToExpr a => ToExpr (Identity a) where-    toExpr (Identity x) = App "Identity" [toExpr x]--instance ToExpr a => ToExpr (Const a b)-instance ToExpr a => ToExpr (ZipList a)--instance ToExpr a => ToExpr (NonEmpty a) where-    toExpr (x :| xs) = App "NE.fromList" [toExpr (x : xs)]--instance ToExpr Void where-    toExpr _ = App "error" [toExpr "Void"]------------------------------------------------------------------------------------ Monoid/semigroups----------------------------------------------------------------------------------instance ToExpr a => ToExpr (Mon.Dual a) where-instance ToExpr a => ToExpr (Mon.Sum a) where-instance ToExpr a => ToExpr (Mon.Product a) where-instance ToExpr a => ToExpr (Mon.First a) where-instance ToExpr a => ToExpr (Mon.Last a) where---- instance ToExpr a => ToExpr (Semi.Option a) where-instance ToExpr a => ToExpr (Semi.Min a) where-instance ToExpr a => ToExpr (Semi.Max a) where-instance ToExpr a => ToExpr (Semi.First a) where-instance ToExpr a => ToExpr (Semi.Last a) where------------------------------------------------------------------------------------ containers----------------------------------------------------------------------------------instance ToExpr a => ToExpr (Tree.Tree a) where-    toExpr (Tree.Node x xs) = App "Node" [toExpr x, toExpr xs]--instance (ToExpr k, ToExpr v) => ToExpr (Map.Map k v) where-    toExpr x = App "Map.fromList" [ toExpr $ Map.toList x ]-instance (ToExpr k) => ToExpr (Set.Set k) where-    toExpr x = App "Set.fromList" [ toExpr $ Set.toList x ]-instance (ToExpr v) => ToExpr (IntMap.IntMap v) where-    toExpr x = App "IntMap.fromList" [ toExpr $ IntMap.toList x ]-instance ToExpr IntSet.IntSet where-    toExpr x = App "IntSet.fromList" [ toExpr $ IntSet.toList x ]-instance (ToExpr v) => ToExpr (Seq.Seq v) where-    toExpr x = App "Seq.fromList" [ toExpr $ toList x ]------------------------------------------------------------------------------------ text------------------------------------------------------------------------------------ | >>> traverse_ (print . prettyExpr . toExpr . LT.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- LT.concat ["foo\n", "bar"]--- LT.concat ["foo\n", "bar\n"]-instance ToExpr LT.Text where-    toExpr = stringToExpr "LT.concat" . unconcat LT.uncons---- | >>> traverse_ (print . prettyExpr . toExpr . T.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- T.concat ["foo\n", "bar"]--- T.concat ["foo\n", "bar\n"]-instance ToExpr T.Text where-    toExpr = stringToExpr "T.concat" . unconcat T.uncons------------------------------------------------------------------------------------ time------------------------------------------------------------------------------------ | >>> prettyExpr $ toExpr $ ModifiedJulianDay 58014--- Day "2017-09-18"-instance ToExpr Time.Day where-    toExpr d = App "Day" [ toExpr (show d) ]--instance ToExpr Time.UTCTime where-    toExpr t = App "UTCTime" [ toExpr (show t) ]------------------------------------------------------------------------------------ bytestring------------------------------------------------------------------------------------ | >>> traverse_ (print . prettyExpr . toExpr . LBS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- LBS.concat ["foo\n", "bar"]--- LBS.concat ["foo\n", "bar\n"]-instance ToExpr LBS.ByteString where-    toExpr = stringToExpr "LBS.concat" . bsUnconcat LBS.null LBS.elemIndex LBS.splitAt---- | >>> traverse_ (print . prettyExpr . toExpr . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- BS.concat ["foo\n", "bar"]--- BS.concat ["foo\n", "bar\n"]-instance ToExpr BS.ByteString where-    toExpr = stringToExpr "BS.concat" . bsUnconcat BS.null BS.elemIndex BS.splitAt---- | >>> traverse_ (print . prettyExpr . toExpr . SBS.toShort . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]--- ""--- "\n"--- "foo"--- "foo\n"--- mconcat ["foo\n", "bar"]--- mconcat ["foo\n", "bar\n"]--- instance ToExpr SBS.ShortByteString where---     toExpr = stringToExpr "mconcat" . bsUnconcat BS.null BS.elemIndex BS.splitAt . SBS.fromShort--bsUnconcat-    :: forall bs int. Num int-    => (bs -> Bool)-    -> (Word8 -> bs -> Maybe int)-    -> (int -> bs -> (bs, bs))-    -> bs-    -> [bs]-bsUnconcat null_ elemIndex_ splitAt_ = go where-    go :: bs -> [bs]-    go bs-        | null_ bs  = []-        | otherwise = case elemIndex_ 10 bs of-            Nothing -> [bs]-            Just i  -> case splitAt_ (i + 1) bs of-                (bs0, bs1) -> bs0 : go bs1------------------------------------------------------------------------------------ scientific------------------------------------------------------------------------------------ | >>> prettyExpr $ toExpr (123.456 :: Scientific)--- scientific 123456 `-3`--- instance ToExpr Sci.Scientific where---     toExpr s = App "scientific" [ toExpr $ Sci.coefficient s, toExpr $ Sci.base10Exponent s ]------------------------------------------------------------------------------------ uuid-types------------------------------------------------------------------------------------ | >>> prettyExpr $ toExpr UUID.nil--- UUID "00000000-0000-0000-0000-000000000000"--- instance ToExpr UUID.UUID where---     toExpr u = App "UUID" [ toExpr $ UUID.toString u ]------------------------------------------------------------------------------------ vector----------------------------------------------------------------------------------instance ToExpr a => ToExpr (V.Vector a) where-    toExpr x = App "V.fromList" [ toExpr $ V.toList x ]-instance (ToExpr a, VU.Unbox a) => ToExpr (VU.Vector a) where-    toExpr x = App "VU.fromList" [ toExpr $ VU.toList x ]-instance (ToExpr a, VS.Storable a) => ToExpr (VS.Vector a) where-    toExpr x = App "VS.fromList" [ toExpr $ VS.toList x ]-instance (ToExpr a, VP.Prim a) => ToExpr (VP.Vector a) where-    toExpr x = App "VP.fromList" [ toExpr $ VP.toList x ]------------------------------------------------------------------------------------ tagged------------------------------------------------------------------------------------ instance ToExpr a => ToExpr (Tagged t a) where---     toExpr (Tagged x) = App "Tagged" [ toExpr x ]------------------------------------------------------------------------------------ hashable------------------------------------------------------------------------------------ instance ToExpr a => ToExpr (Hashed a) where---     toExpr x = App "hashed" [ toExpr $ unhashed x ]------------------------------------------------------------------------------------ unordered-containers------------------------------------------------------------------------------------ instance (ToExpr k, ToExpr v) => ToExpr (HM.HashMap k v) where---     toExpr x = App "HM.fromList" [ toExpr $ HM.toList x ]--- instance (ToExpr k) => ToExpr (HS.HashSet k) where---     toExpr x = App "HS.fromList" [ toExpr $ HS.toList x ]------------------------------------------------------------------------------------ aeson------------------------------------------------------------------------------------ instance ToExpr Aeson.Value------------------------------------------------------------------------------------ Doctest------------------------------------------------------------------------------------ $setup--- >>> :set -XDeriveGeneric--- >>> :set -XDeriveGeneric--- >>> import Data.Foldable (traverse_)--- >>> import Data.Ratio ((%))--- >>> import Data.Time (Day (..))--- >>> import Data.Scientific (Scientific)--- >>> import Data.TreeDiff.Pretty--- >>> import qualified Data.ByteString.Char8 as BS8--- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8
− src/Test/StateMachine/TreeDiff/Expr.hs 
@@ -1,102 +0,0 @@--- | This module uses 'Expr' for richer diffs than based on 'Tree'.-module Test.StateMachine.TreeDiff.Expr (-    -- * Types-    Expr (..),-    ConstructorName,-    FieldName,-    EditExpr (..),-    Edit (..),-    exprDiff,-    ) where--import Prelude ()-import Prelude.Compat--import Data.Map           (Map)-import Test.StateMachine.TreeDiff.List--import qualified Data.Map        as Map-import qualified Test.QuickCheck as QC---- | Constructor name is a string-type ConstructorName = String------ | Record field name is a string too.-type FieldName       = String---- | A untyped Haskell-like expression.------ Having richer structure than just 'Tree' allows to have richer diffs.-data Expr-    = App ConstructorName [Expr]                 -- ^ application-    | Rec ConstructorName (Map FieldName Expr)   -- ^ record constructor-    | Lst [Expr]                                 -- ^ list constructor-  deriving (Eq, Show)--instance QC.Arbitrary Expr where-    arbitrary = QC.scale (min 25) $ QC.sized arb where-        arb n | n <= 0 = QC.oneof-            [ (`App` []) <$> arbName-            ,  (`Rec` mempty) <$> arbName-            ]-        arb n | otherwise = do-            n' <- QC.choose (0, n `div` 3)-            QC.oneof-                [ App <$> arbName <*> QC.liftArbitrary (arb n')-                , Rec <$> arbName <*> QC.liftArbitrary (arb n')-                , Lst <$> QC.liftArbitrary (arb n')-                ]--    shrink (Lst es)   = es-        ++ [ Lst es'    | es' <- QC.shrink es ]-    shrink (Rec n fs) = Map.elems fs-        ++ [ Rec n' fs  | n'  <- QC.shrink n  ]-        ++ [ Rec n  fs' | fs' <- QC.shrink fs ]-    shrink (App n es) = es-        ++ [ App n' es  | n'  <- QC.shrink n  ]-        ++ [ App n  es' | es' <- QC.shrink es ]--arbName :: QC.Gen String-arbName = QC.frequency-    [ (10, QC.liftArbitrary $ QC.elements $ ['a'..'z'] ++ ['0' .. '9'] ++ "+-_:")-    , (1, show <$> (QC.arbitrary :: QC.Gen String))-    , (1, QC.arbitrary)-    , (1, QC.elements ["_×_", "_×_×_", "_×_×_×_"])-    ]---- | Diff two 'Expr'.------ For examples see 'ediff' in "Data.TreeDiff.Class".-exprDiff :: Expr -> Expr -> Edit EditExpr-exprDiff = impl-  where-    impl ea eb | ea == eb = Cpy (EditExp ea)--    impl ea@(App a as) eb@(App b bs)-        | a == b = Cpy $ EditApp a (map recurse (diffBy (==) as bs))-        | otherwise = Swp (EditExp ea) (EditExp eb)-    impl ea@(Rec a as) eb@(Rec b bs)-        | a == b = Cpy $ EditRec a $ Map.unions [inter, onlyA, onlyB]-        | otherwise = Swp (EditExp ea) (EditExp eb)-      where-        inter = Map.intersectionWith exprDiff as bs-        onlyA = fmap (Del . EditExp) (Map.difference as inter)-        onlyB = fmap (Ins . EditExp) (Map.difference bs inter)-    impl (Lst as) (Lst bs) =-        Cpy $ EditLst (map recurse (diffBy (==) as bs))--    -- If higher level doesn't match, just swap.-    impl a b = Swp (EditExp a) (EditExp b)--    recurse (Ins x)   = Ins (EditExp x)-    recurse (Del y)   = Del (EditExp y)-    recurse (Cpy z)   = Cpy (EditExp z)-    recurse (Swp x y) = impl x y---- | Type used in the result of 'ediff'.-data EditExpr-    = EditApp ConstructorName [Edit EditExpr]-    | EditRec ConstructorName (Map FieldName (Edit EditExpr))-    | EditLst [Edit EditExpr]-    | EditExp Expr  -- ^ unchanged tree-  deriving Show
− src/Test/StateMachine/TreeDiff/List.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | A list diff.-module Test.StateMachine.TreeDiff.List (diffBy, Edit (..)) where--import Data.List.Compat (sortOn)-import qualified Data.MemoTrie as M-import qualified Data.Vector as V---- | List edit operations------ The 'Swp' constructor is redundant, but it let us spot--- a recursion point when performing tree diffs.-data Edit a-    = Ins a    -- ^ insert-    | Del a    -- ^ delete-    | Cpy a    -- ^ copy unchanged-    | Swp a a  -- ^ swap, i.e. delete + insert-  deriving Show---- | List difference.------ >>> diffBy (==) "hello" "world"--- [Swp 'h' 'w',Swp 'e' 'o',Swp 'l' 'r',Cpy 'l',Swp 'o' 'd']------ >>> diffBy (==) "kitten" "sitting"--- [Swp 'k' 's',Cpy 'i',Cpy 't',Cpy 't',Swp 'e' 'i',Cpy 'n',Ins 'g']------ prop> \xs ys -> length (diffBy (==) xs ys) >= max (length xs) (length (ys :: String))--- prop> \xs ys -> length (diffBy (==) xs ys) <= length xs + length (ys :: String)------ /Note:/ currently this has O(n*m) memory requirements, for the sake--- of more obviously correct implementation.----diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]-diffBy eq xs' ys' = reverse (snd (lcs (V.length xs) (V.length ys)))-  where-    xs = V.fromList xs'-    ys = V.fromList ys'--    lcs = M.memo2 impl--    impl :: Int -> Int -> (Int, [Edit a])-    impl 0 0 = (0, [])-    impl 0 m = case lcs 0 (m-1) of-        (w, edit) -> (w + 1, Ins (ys V.! (m - 1)) : edit)-    impl n 0 = case lcs (n -1) 0 of-        (w, edit) -> (w + 1, Del (xs V.! (n - 1)) : edit)--    impl n m = head $ sortOn fst-        [ edit-        , bimap (+1) (Ins y :) (lcs n (m - 1))-        , bimap (+1) (Del x :) (lcs (n - 1) m)-        ]-      where-        x = xs V.! (n - 1)-        y = ys V.! (m - 1)--        edit-            | eq x y    = bimap id   (Cpy x :)   (lcs (n - 1) (m - 1))-            | otherwise = bimap (+1) (Swp x y :) (lcs (n -1 ) (m - 1))--bimap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)-bimap f g (x, y) = (f x, g y)
− src/Test/StateMachine/TreeDiff/Pretty.hs 
@@ -1,253 +0,0 @@--- | Utilities to pretty print 'Expr' and 'EditExpr'-module Test.StateMachine.TreeDiff.Pretty (-    -- * Explicit dictionary-    Pretty (..),-    ppExpr,-    ppEditExpr,-    ppEditExprCompact,-    -- * pretty-    prettyPretty,-    prettyExpr,-    prettyEditExpr,-    prettyEditExprCompact,-    -- * ansi-wl-pprint-    ansiWlPretty,-    ansiWlExpr,-    ansiWlEditExpr,-    ansiWlEditExprCompact,-    -- ** background-    ansiWlBgPretty,-    ansiWlBgExpr,-    ansiWlBgEditExpr,-    ansiWlBgEditExprCompact,-    -- * Utilities-    escapeName,-    ) where--import Data.Char          (isAlphaNum, isPunctuation, isSymbol, ord)-import Data.Either        (partitionEithers)-import Test.StateMachine.TreeDiff.Expr-import Numeric            (showHex)-import Text.Read          (readMaybe)---import qualified Data.Map                     as Map-import qualified Text.PrettyPrint             as HJ-import qualified Text.PrettyPrint.ANSI.Leijen as WL---- | Because we don't want to commit to single pretty printing library,--- we use explicit dictionary.-data Pretty doc = Pretty-    { ppCon        :: ConstructorName -> doc-    , ppRec        :: [(FieldName, doc)] -> doc-    , ppLst        :: [doc] -> doc-    , ppCpy        :: doc -> doc-    , ppIns        :: doc -> doc-    , ppDel        :: doc -> doc-    , ppSep        :: [doc] -> doc-    , ppParens     :: doc -> doc-    , ppHang       :: doc -> doc -> doc-    }---- | Escape field or constructor name------ >>> putStrLn $ escapeName "Foo"--- Foo------ >>> putStrLn $ escapeName "_×_"--- _×_------ >>> putStrLn $ escapeName "-3"--- `-3`------ >>> putStrLn $ escapeName "kebab-case"--- kebab-case------ >>> putStrLn $ escapeName "inner space"--- `inner space`------ >>> putStrLn $ escapeName $ show "looks like a string"--- "looks like a string"------ >>> putStrLn $ escapeName $ show "tricky" ++ "   "--- `"tricky"   `------ >>> putStrLn $ escapeName "[]"--- `[]`------ >>> putStrLn $ escapeName "_,_"--- `_,_`----escapeName :: String -> String-escapeName n-    | null n                      = "``"-    | isValidString n             = n-    | all valid' n && headNotMP n = n-    | otherwise                   = "`" ++ concatMap e n ++ "`"-  where-    e '`'               = "\\`"-    e '\\'              = "\\\\"-    e ' '               = " "-    e c | not (valid c) = "\\x" ++ showHex (ord c) ";"-    e c                 = [c]--    valid c = isAlphaNum c || isSymbol c || isPunctuation c-    valid' c = valid c && c `notElem` "[](){}`\","--    headNotMP ('-' : _) = False-    headNotMP ('+' : _) = False-    headNotMP _         = True--    isValidString s-        | length s >= 2 && head s == '"' && last s == '"' =-            case readMaybe s :: Maybe String of-                Just _ -> True-                Nothing -> False-    isValidString _         = False---- | Pretty print an 'Expr' using explicit pretty-printing dictionary.-ppExpr :: Pretty doc -> Expr -> doc-ppExpr p = ppExpr' p False--ppExpr' :: Pretty doc -> Bool -> Expr -> doc-ppExpr' p = impl where-    impl _ (App x []) = ppCon p (escapeName x)-    impl b (App x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $-        ppSep p $ map (impl True) xs-    impl _ (Rec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $-        map ppField' $ Map.toList xs-    impl _ (Lst xs)   = ppLst p (map (impl False) xs)--    ppField' (n, e) = (escapeName n, impl False e)--    ppParens' True  = ppParens p-    ppParens' False = id---- | Pretty print an @'Edit' 'EditExpr'@ using explicit pretty-printing dictionary.-ppEditExpr :: Pretty doc -> Edit EditExpr -> doc-ppEditExpr = ppEditExpr' False---- | Like 'ppEditExpr' but print unchanged parts only shallowly-ppEditExprCompact :: Pretty doc -> Edit EditExpr -> doc-ppEditExprCompact = ppEditExpr' True--ppEditExpr' :: Bool -> Pretty doc -> Edit EditExpr -> doc-ppEditExpr' compact p = ppSep p . ppEdit False-  where-    ppEdit b (Cpy (EditExp expr)) = [ ppCpy p $ ppExpr' p b expr ]-    ppEdit b (Cpy expr) = [ ppEExpr b expr ]-    ppEdit b (Ins expr) = [ ppIns p (ppEExpr b expr) ]-    ppEdit b (Del expr) = [ ppDel p (ppEExpr b expr) ]-    ppEdit b (Swp x y) =-        [ ppDel p (ppEExpr b x)-        , ppIns p (ppEExpr b y)-        ]--    ppEExpr _ (EditApp x []) = ppCon p (escapeName x)-    ppEExpr b (EditApp x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $-        ppSep p $ concatMap (ppEdit True) xs-    ppEExpr _ (EditRec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $-        justs ++ [ (n, ppCon p "...") | n <- take 1 nothings ]-      where-        xs' = map ppField' $ Map.toList xs-        (nothings, justs) = partitionEithers xs'--    ppEExpr _ (EditLst xs)   = ppLst p (concatMap (ppEdit False) xs)-    ppEExpr b (EditExp x)    = ppExpr' p b x--    ppField' (n, Cpy (EditExp e)) | compact, not (isScalar e) = Left n-    ppField' (n, e) = Right (escapeName n, ppSep p $ ppEdit False e)--    ppParens' True  = ppParens p-    ppParens' False = id--    isScalar (App _ []) = True-    isScalar _          = False------------------------------------------------------------------------------------ pretty------------------------------------------------------------------------------------ | 'Pretty' via @pretty@ library.-prettyPretty :: Pretty HJ.Doc-prettyPretty = Pretty-    { ppCon    = HJ.text-    , ppRec    = HJ.braces . HJ.sep . HJ.punctuate HJ.comma-               . map (\(fn, d) -> HJ.text fn HJ.<+> HJ.equals HJ.<+> d)-    , ppLst    = HJ.brackets . HJ.sep . HJ.punctuate HJ.comma-    , ppCpy    = id-    , ppIns    = \d -> HJ.char '+' HJ.<> d-    , ppDel    = \d -> HJ.char '-' HJ.<> d-    , ppSep    = HJ.sep-    , ppParens = HJ.parens-    , ppHang   = \d1 d2 -> HJ.hang d1 2 d2-    }---- | Pretty print 'Expr' using @pretty@.------ >>> prettyExpr $ Rec "ex" (Map.fromList [("[]", App "bar" [])])--- ex {`[]` = bar}-prettyExpr :: Expr -> HJ.Doc-prettyExpr = ppExpr prettyPretty---- | Pretty print @'Edit' 'EditExpr'@ using @pretty@.-prettyEditExpr :: Edit EditExpr -> HJ.Doc-prettyEditExpr = ppEditExpr prettyPretty---- | Compact 'prettyEditExpr'.-prettyEditExprCompact :: Edit EditExpr -> HJ.Doc-prettyEditExprCompact = ppEditExprCompact prettyPretty------------------------------------------------------------------------------------ ansi-wl-pprint------------------------------------------------------------------------------------ | 'Pretty' via @ansi-wl-pprint@ library (with colors).-ansiWlPretty :: Pretty WL.Doc-ansiWlPretty = Pretty-    { ppCon    = WL.text-    , ppRec    = WL.encloseSep WL.lbrace WL.rbrace WL.comma-               . map (\(fn, d) -> WL.text fn WL.<+> WL.equals WL.</> d)-    , ppLst    = WL.list-    , ppCpy    = WL.dullwhite-    , ppIns    = \d -> WL.green $ WL.plain $ WL.char '+' WL.<> d-    , ppDel    = \d -> WL.red   $ WL.plain $ WL.char '-' WL.<> d-    , ppSep    = WL.sep-    , ppParens = WL.parens-    , ppHang   = \d1 d2 -> WL.hang 2 (d1 WL.</> d2)-    }---- | Pretty print 'Expr' using @ansi-wl-pprint@.-ansiWlExpr :: Expr -> WL.Doc-ansiWlExpr = ppExpr ansiWlPretty---- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.-ansiWlEditExpr :: Edit EditExpr -> WL.Doc-ansiWlEditExpr = ppEditExpr ansiWlPretty---- | Compact 'ansiWlEditExpr'-ansiWlEditExprCompact :: Edit EditExpr -> WL.Doc-ansiWlEditExprCompact = ppEditExprCompact ansiWlPretty------------------------------------------------------------------------------------ Background------------------------------------------------------------------------------------ | Like 'ansiWlPretty' but color the background.-ansiWlBgPretty :: Pretty WL.Doc-ansiWlBgPretty = ansiWlPretty-    { ppIns    = \d -> WL.ondullgreen $ WL.white $ WL.plain $ WL.char '+' WL.<> d-    , ppDel    = \d -> WL.ondullred   $ WL.white $ WL.plain $ WL.char '-' WL.<> d-    }---- | Pretty print 'Expr' using @ansi-wl-pprint@.-ansiWlBgExpr :: Expr -> WL.Doc-ansiWlBgExpr = ppExpr ansiWlBgPretty---- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.-ansiWlBgEditExpr :: Edit EditExpr -> WL.Doc-ansiWlBgEditExpr = ppEditExpr ansiWlBgPretty---- | Compact 'ansiWlBgEditExpr'.-ansiWlBgEditExprCompact :: Edit EditExpr -> WL.Doc-ansiWlBgEditExprCompact = ppEditExprCompact ansiWlBgPretty
− src/Test/StateMachine/TreeDiff/Tree.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE CPP #-}--- | Tree diffing working on @containers@ 'Tree'.-module Test.StateMachine.TreeDiff.Tree (treeDiff, EditTree (..), Edit (..)) where--import Data.Tree          (Tree (..))-import Test.StateMachine.TreeDiff.List--#ifdef __DOCTEST__-import qualified Text.PrettyPrint as PP-#endif---- | A breadth-traversal diff.------ It's different from @gdiff@, as it doesn't produce a flat edit script,--- but edit script iself is a tree. This makes visualising the diff much--- simpler.------ ==== Examples------ Let's start from simple tree. We pretty print them as s-expressions.------ >>> let x = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'e'], Node 'f' []]--- >>> ppTree PP.char x--- (a b (c d e) f)------ If we modify an argument in a tree, we'll notice it's changed:------ >>> let y = Node 'a' [Node 'b' [], Node 'c' [return 'x', return 'e'], Node 'f' []]--- >>> ppTree PP.char y--- (a b (c x e) f)------ >>> ppEditTree PP.char (treeDiff x y)--- (a b (c -d +x e) f)------ If we modify a constructor, the whole sub-trees is replaced, though there--- might be common subtrees.------ >>> let z = Node 'a' [Node 'b' [], Node 'd' [], Node 'f' []]--- >>> ppTree PP.char z--- (a b d f)------ >>> ppEditTree PP.char (treeDiff x z)--- (a b -(c d e) +d f)------ If we add arguments, they are spotted too:------ >>> let w = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'x', return 'e'], Node 'f' []]--- >>> ppTree PP.char w--- (a b (c d x e) f)------ >>> ppEditTree PP.char (treeDiff x w)--- (a b (c d +x e) f)----treeDiff :: Eq a => Tree a -> Tree a -> Edit (EditTree a)-treeDiff ta@(Node a as) tb@(Node b bs)-    | a == b = Cpy $ EditNode a (map rec (diffBy (==) as bs))-    | otherwise = Swp (treeToEdit ta) (treeToEdit tb)-  where-    rec (Ins x)   = Ins (treeToEdit x)-    rec (Del y)   = Del (treeToEdit y)-    rec (Cpy z)   = Cpy (treeToEdit z)-    rec (Swp x y) = treeDiff x y---- | Type used in the result of 'treeDiff'.------ It's essentially a 'Tree', but the forest list is changed from--- @[tree a]@ to @['Edit' (tree a)]@. This highlights that--- 'treeDiff' performs a list diff on each tree level.-data EditTree a-    = EditNode a [Edit (EditTree a)]-  deriving Show--treeToEdit :: Tree a -> EditTree a-treeToEdit = go where go (Node x xs) = EditNode x (map (Cpy . go) xs)--#ifdef __DOCTEST__-ppTree :: (a -> PP.Doc) -> Tree a -> PP.Doc-ppTree pp = ppT-  where-    ppT (Node x []) = pp x-    ppT (Node x xs) = PP.parens $ PP.hang (pp x) 2 $-        PP.sep $ map ppT xs--ppEditTree :: (a -> PP.Doc) -> Edit (EditTree a) -> PP.Doc-ppEditTree pp = PP.sep . ppEdit-  where-    ppEdit (Cpy tree) = [ ppTree tree ]-    ppEdit (Ins tree) = [ PP.char '+' PP.<> ppTree tree ]-    ppEdit (Del tree) = [ PP.char '-' PP.<> ppTree tree ]-    ppEdit (Swp a b) =-        [ PP.char '-' PP.<> ppTree a-        , PP.char '+' PP.<> ppTree b-        ]--    ppTree (EditNode x []) = pp x-    ppTree (EditNode x xs) = PP.parens $ PP.hang (pp x) 2 $-       PP.sep $ concatMap ppEdit xs-#endif
src/Test/StateMachine/Types/References.hs view
@@ -43,15 +43,12 @@                    (Generic) import           Prelude -import           Test.StateMachine.TreeDiff-                   (Expr(App), ToExpr, toExpr) import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------  newtype Var = Var Int   deriving stock   (Eq, Ord, Show, Generic, Read)-  deriving newtype (ToExpr)  data Symbolic a where   Symbolic :: Typeable a => Var -> Symbolic a@@ -69,9 +66,6 @@     where       appPrec = 10 -instance ToExpr a => ToExpr (Symbolic a) where-  toExpr (Symbolic x) = toExpr x- instance Eq1 Symbolic where   liftEq _ (Symbolic x) (Symbolic y) = x == y @@ -101,16 +95,11 @@ instance Ord1 Concrete where   liftCompare comp (Concrete x) (Concrete y) = comp x y -instance ToExpr a => ToExpr (Concrete a) where-  toExpr (Concrete x) = toExpr x- newtype Reference a r = Reference (r a)   deriving stock Generic  deriving stock instance Typeable a => Read (Reference a Symbolic) -instance ToExpr (r a) => ToExpr (Reference a r)- instance Rank2.Functor (Reference a) where   fmap f (Reference r) = Reference (f r) @@ -148,6 +137,3 @@  instance Show (Opaque a) where   showsPrec _ (Opaque _) = showString "Opaque"--instance ToExpr (Opaque a) where-  toExpr _ = App "Opaque" []
test/Bookstore.hs view
@@ -58,6 +58,7 @@                    throwIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2      as Rank2 import           Test.StateMachine.Z                    (codomain, domain)@@ -143,12 +144,12 @@   :: Bug -> String -> Connection -> IO (Maybe [Book]) findByAuthor bug s = case bug of   Injection -> handleViolations (select templ $ "%"++s++"%")-  _          -> handleViolations (select templ $ "%"++(sanitize s)++"%")+  _         -> handleViolations (select templ $ "%"++(sanitize s)++"%")   where templ = "SELECT * FROM books WHERE author LIKE ?"  findByTitle bug s = case bug of   Injection -> handleViolations (select templ $ "%"++s++"%")-  _          -> handleViolations (select templ $ "%"++(sanitize s)++"%")+  _         -> handleViolations (select templ $ "%"++(sanitize s)++"%")   where templ = "SELECT * FROM books WHERE title LIKE ?"  findByIsbn :: String -> Connection -> IO (Maybe [Book])@@ -347,10 +348,10 @@ transitions :: Model r -> Command r -> Response r -> Model r transitions (Model m) cmd _ = Model $ case cmd of   NewBook New key t a -> (key, Book (getString key) t a 0 0):m-  AddCopy Exist key -> map (applyForKey key $ incOwned . incAvail) m-  Borrow  Avail key -> map (applyForKey key decAvail) m-  Return  Taken key -> map (applyForKey key incAvail) m-  _ -> m+  AddCopy Exist key   -> map (applyForKey key $ incOwned . incAvail) m+  Borrow  Avail key   -> map (applyForKey key decAvail) m+  Return  Taken key   -> map (applyForKey key incAvail) m+  _                   -> m   where     applyForKey key fn (k, v) = (k, if k == key then fn v else v)     incOwned row = row { owned = 1 + owned row }
test/CircularBuffer.hs view
@@ -61,6 +61,7 @@                    (monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/Cleanup.hs view
@@ -41,7 +41,9 @@ import           Test.QuickCheck.Monadic                    (monadicIO) import           Test.StateMachine-import qualified Test.StateMachine.Types as QSM (initModel)+import           Test.StateMachine.TreeDiff+import qualified Test.StateMachine.Types       as QSM+                   (initModel) import qualified Test.StateMachine.Types.Rank2 as Rank2 import           Test.StateMachine.Utils                    (liftProperty, mkModel, whenFailM)
test/CrudWebserverDb.hs view
@@ -131,7 +131,7 @@  import           Test.StateMachine import           Test.StateMachine.TreeDiff-                   (Expr(App))+                   (Expr(App), ToExpr(toExpr)) import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/DieHard.hs view
@@ -41,6 +41,7 @@                    (monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/Echo.hs view
@@ -39,7 +39,8 @@                    (TVar, atomically, newTVarIO, readTVar, writeTVar)  import           Test.StateMachine-import           Test.StateMachine.Types as QC+import           Test.StateMachine.TreeDiff+import           Test.StateMachine.Types       as QC import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/ErrorEncountered.hs view
@@ -26,6 +26,7 @@                    (monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2 import           Test.StateMachine.Z
test/Hanoi.hs view
@@ -42,6 +42,7 @@                    (monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import           Test.StateMachine.TreeDiff.Expr                    () import qualified Test.StateMachine.Types.Rank2   as Rank2
test/IORefs.hs view
@@ -29,6 +29,7 @@ import qualified Data.Map.Strict                   as Map  import           Test.StateMachine.Lockstep.Simple+import           Test.StateMachine.TreeDiff  {-------------------------------------------------------------------------------   Instantiate the simple API
test/MemoryReference.hs view
@@ -38,8 +38,8 @@ import           System.Random                    (randomIO, randomRIO) import           Test.QuickCheck-                   (Gen, Property, arbitrary, elements, frequency,-                   once, shrink, (===))+                   (Gen, Property, arbitrary, elements, frequency, once,+                   shrink, (===)) import           Test.QuickCheck.Monadic                    (monadicIO) @@ -50,14 +50,15 @@                    shrinkNParallelCommands, shrinkParallelCommands) import           Test.StateMachine.Sequential                    (ShouldShrink(..))+import           Test.StateMachine.TreeDiff+import qualified Test.StateMachine.Types       as Types import           Test.StateMachine.Types                    (Commands(Commands), Reference(..), Symbolic(..),                    Var(Var))-import qualified Test.StateMachine.Types       as Types import qualified Test.StateMachine.Types.Rank2 as Rank2 import           Test.StateMachine.Utils-                   (Shrunk(..), shrinkListS, shrinkListS'',-                   shrinkPairS, shrinkPairS')+                   (Shrunk(..), shrinkListS, shrinkListS'', shrinkPairS,+                   shrinkPairS') import           Test.StateMachine.Z  ------------------------------------------------------------------------
test/Mock.hs view
@@ -27,6 +27,7 @@                    (monadicIO) import           Test.StateMachine import           Test.StateMachine.DotDrawing+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/Overflow.hs view
@@ -32,6 +32,7 @@                    (monadicIO) import           Test.StateMachine import           Test.StateMachine.DotDrawing+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/ProcessRegistry.hs view
@@ -80,6 +80,7 @@  import           Test.StateMachine import           Test.StateMachine.Labelling+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2
test/SQLite.hs view
@@ -34,7 +34,7 @@ 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@@ -46,8 +46,7 @@                    (Text, pack) import           Database.Persist import           Database.Persist.Sqlite-import           Database.Sqlite                 hiding-                   (step)+import           Database.Sqlite import           GHC.Generics                    (Generic, Generic1) import           Prelude@@ -56,9 +55,9 @@ import           Test.QuickCheck.Monadic import           Test.StateMachine import           Test.StateMachine.DotDrawing-import           Test.StateMachine.TreeDiff.Expr+import           Test.StateMachine.TreeDiff import           Test.StateMachine.Types-import qualified Test.StateMachine.Types.Rank2   as Rank2+import qualified Test.StateMachine.Types.Rank2 as Rank2  import           Schema @@ -161,7 +160,7 @@     , eventMockResp = mockResp     }   where-    (mockResp, dbModel') = step model cmd+    (mockResp, dbModel') = stepModel model cmd     newPerson = zip (getPers $ unAt resp) (getPers mockResp)     newCars = zip (getCars $ unAt resp) (getCars mockResp) @@ -196,10 +195,10 @@ canInsertC :: Car -> [Car] -> Bool canInsertC c cs = carCid c `notElem` (carCid <$> cs) -step :: Model r-     -> At Cmd r-     -> (Resp Int Int, DBModel)-step Model{..} =  runPure dbModel+stepModel :: Model r+          -> At Cmd r+          -> (Resp Int Int, DBModel)+stepModel Model{..} =  runPure dbModel  runPure :: DBModel -> At Cmd r -> (Resp Int Int, DBModel) runPure dbModel@DBModel{..} cmd  = case unAt cmd of@@ -220,7 +219,7 @@ mockImpl :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic) mockImpl model cmdErr = At <$> bitraverse (const genSym) (const genSym) mockResp     where-        (mockResp, _model') = step model cmdErr+        (mockResp, _model') = stepModel model cmdErr  shrinkerImpl :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic] shrinkerImpl _ _ = []@@ -458,9 +457,14 @@  createSqliteAsyncQueue :: (MonadLoggerIO m, MonadUnliftIO m)                        => Text -> m (AsyncQueue SqlBackend)-createSqliteAsyncQueue str = do+createSqliteAsyncQueue str0 = do     logFunc <- askLoggerIO-    liftIO $ asyncQueueBound 1000 $ open' str logFunc+    liftIO $ asyncQueueBound 1000 $ openWrap str0 logFunc+  where+    openWrap :: Text -> LogFunc -> IO SqlBackend+    openWrap str logFunc = do+        conn <- open str+        wrapConnection conn logFunc `onException` close conn  createSqliteAsyncPool :: (MonadLoggerIO m, MonadUnliftIO m)     => Text -> Int -> m (AsyncWithPool SqlBackend)@@ -468,11 +472,6 @@     q <- createSqliteAsyncQueue str     p <- createSqlitePool str n     return $ mkAsyncWithPool q p--open' :: Text -> LogFunc -> IO SqlBackend-open' str logFunc = do-    conn <- open str-    wrapConnection conn logFunc `onException` close conn  runSqlAsyncWrite :: MonadUnliftIO m => ReaderT SqlBackend m a -> AsyncWithPool SqlBackend -> m a runSqlAsyncWrite r a = runSqlAsyncQueue r (queue a)
test/ShrinkingProps.hs view
@@ -66,7 +66,6 @@ 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
test/TicketDispenser.hs view
@@ -62,6 +62,7 @@                    (PropertyM, monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2 as Rank2  ------------------------------------------------------------------------
test/UnionFind.hs view
@@ -40,6 +40,7 @@                    (monadicIO)  import           Test.StateMachine+import           Test.StateMachine.TreeDiff import qualified Test.StateMachine.Types.Rank2      as Rank2 import           Test.StateMachine.Types.References import           Test.StateMachine.Z
+ tree-diff/Test/StateMachine/TreeDiff.hs view
@@ -0,0 +1,23 @@+-- | 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.Class+import           Test.StateMachine.TreeDiff.Diffing+                   ()+import           Test.StateMachine.TreeDiff.Expr+import           Test.StateMachine.TreeDiff.Pretty
+ tree-diff/Test/StateMachine/TreeDiff/Class.hs view
@@ -0,0 +1,491 @@+{-# 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.List.Compat+                   (uncons)+import           Data.Proxy+                   (Proxy(..))+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           Test.StateMachine.TreeDiff.Expr++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
+ tree-diff/Test/StateMachine/TreeDiff/Diffing.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Implements @CanDiff@ with our vendored version of @tree-diff@.+module Test.StateMachine.TreeDiff.Diffing () where++import           Data.SOP+import           Test.StateMachine.Diffing+import qualified Test.StateMachine.Lockstep.NAry    as NAry+import qualified Test.StateMachine.Lockstep.Simple  as Simple+import           Test.StateMachine.TreeDiff.Class+import           Test.StateMachine.TreeDiff.Expr+import           Test.StateMachine.TreeDiff.Pretty+import           Test.StateMachine.Types.References++instance ToExpr x => CanDiff x where+  type ADiff  x = Edit EditExpr+  type AnExpr x = Expr++  toDiff             = toExpr+  exprDiff         _ = Test.StateMachine.TreeDiff.Expr.exprDiff+  diffToDocCompact _ = ansiWlBgEditExprCompact+  diffToDoc        _ = ansiWlBgEditExpr+  exprToDoc        _ = ansiWlBgExpr++-- References++deriving newtype instance ToExpr Var++instance ToExpr a => ToExpr (Symbolic a) where+  toExpr (Symbolic x) = toExpr x++instance ToExpr a => ToExpr (Concrete a) where+  toExpr (Concrete x) = toExpr x++instance ToExpr (r a) => ToExpr (Reference a r)++instance ToExpr (Opaque a) where+  toExpr _ = App "Opaque" []++-- Simple++instance ToExpr (Simple.MockHandle t)+      => ToExpr (NAry.MockHandleN (Simple.Simple t) (Simple.RealHandle t)) where+  toExpr (Simple.SimpleToMock h) = toExpr h++-- NAry++deriving+  newtype+  instance (ToExpr a, ToExpr (NAry.MockHandleN t a)) => ToExpr (NAry.Refs t Concrete a)++instance All (And ToExpr (Compose ToExpr (NAry.MockHandleN t))) (NAry.RealHandles t)+      => ToExpr (NAry.Refss t Concrete) where+  toExpr = Lst+         . hcollapse+         . hcmap (Proxy @(And ToExpr (Compose ToExpr (NAry.MockHandleN t)))) toExprOne+         . NAry.unRefss+    where+      toExprOne :: (ToExpr a, ToExpr (NAry.MockHandleN t a))+                => NAry.Refs t Concrete a -> K Expr a+      toExprOne = K . toExpr++instance ( ToExpr (NAry.MockState t)+         , All (And ToExpr (Compose ToExpr (NAry.MockHandleN t))) (NAry.RealHandles t)+         ) => ToExpr (NAry.Model t Concrete)
+ tree-diff/Test/StateMachine/TreeDiff/Expr.hs view
@@ -0,0 +1,104 @@+-- | 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
+ tree-diff/Test/StateMachine/TreeDiff/List.hs view
@@ -0,0 +1,64 @@+{-# 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)
+ tree-diff/Test/StateMachine/TreeDiff/Pretty.hs view
@@ -0,0 +1,257 @@+-- | 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           Numeric+                   (showHex)+import           Test.StateMachine.TreeDiff.Expr+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
+ tree-diff/Test/StateMachine/TreeDiff/Tree.hs view
@@ -0,0 +1,99 @@+{-# 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