From 955249376193f3b2cebbccf9721c130f388f3ed6 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Sun, 23 Jan 2022 19:38:47 +0200 Subject: [PATCH 01/62] Initial import Signed-off-by: Radu Ometita --- .gitignore | 2 ++ ChangeLog.md | 3 ++ LICENSE | 30 +++++++++++++++++++ README.md | 1 + Setup.hs | 2 ++ app/Main.hs | 6 ++++ package.yaml | 55 +++++++++++++++++++++++++++++++++++ src/Lib.hs | 6 ++++ stack.yaml | 67 ++++++++++++++++++++++++++++++++++++++++++ stack.yaml.lock | 13 +++++++++ test/Model.hs | 75 ++++++++++++++++++++++++++++++++++++++++++++++++ test/Spec.hs | 18 ++++++++++++ utxo-index.cabal | 73 ++++++++++++++++++++++++++++++++++++++++++++++ 13 files changed, 351 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 src/Lib.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 test/Model.hs create mode 100644 test/Spec.hs create mode 100644 utxo-index.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..c368d453bc --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work/ +*~ \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000000..a4b9dfbe7e --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for utxo-index + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000000..342c588b3a --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000000..edf36c2c48 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# utxo-index diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000000..de1c1ab35c --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000000..8751eda17d --- /dev/null +++ b/package.yaml @@ -0,0 +1,55 @@ +name: utxo-index +version: 0.1.0.0 +github: "githubuser/utxo-index" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2022 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +default-extensions: + - ImportQualifiedPost + - ExplicitForAll + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + +executables: + utxo-index-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - utxo-index + +tests: + utxo-index-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - utxo-index + - QuickCheck + - tasty + - tasty-quickcheck diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000000..d36ff2714d --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000000..33b9472fa1 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000000..9b8df1d045 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,13 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: f9970d6f25c63e3e4265aa8e9c69a047ba8919d1107e4996bdd7555b75aad0eb + size: 586120 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml diff --git a/test/Model.hs b/test/Model.hs new file mode 100644 index 0000000000..64e5756aeb --- /dev/null +++ b/test/Model.hs @@ -0,0 +1,75 @@ +module Model ( -- * Model data + HistoricalFold + -- * Model functionality + , new + , insert + , view + , historyLength + , rewind + -- * Helpers + , insertL + -- * QuickCheck instrumentation + ) where + +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) + +import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, + choose, listOf, sized) + +-- | Model of a historical (we can go backwards) fold over a data set. + +data HistoricalFold a b = HistoricalFold + { hfFunction :: a -> b -> a + , hfDepth :: Int + , hfAccumulator :: NonEmpty a + } + +-- | Operations over the historical folds. + +new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) +new fn depth acc + | depth <= 0 = Nothing + | otherwise = Just $ + HistoricalFold { hfFunction = fn + , hfDepth = depth + , hfAccumulator = acc :| [] + } + +insert :: b -> HistoricalFold a b -> HistoricalFold a b +insert v hf@(HistoricalFold fn depth acc@(hacc :| _)) = + -- TODO: forall hf v. historyLength (insert v hf) > 0 + hf { hfAccumulator = NE.fromList $ NE.take depth $ + fn hacc v <| acc } + +insertL :: [b] -> HistoricalFold a b -> HistoricalFold a b +insertL bs hf = foldl' (flip insert) hf bs + +view :: HistoricalFold a b -> a +view (HistoricalFold _ _ (hacc :| _)) = hacc + +historyLength :: HistoricalFold a b -> Int +historyLength (HistoricalFold _ _ acc) = NE.length acc + +rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) +-- TODO: Check all Nothing/Just cases. +rewind depth hf + | hfDepth hf < depth = Nothing + | historyLength hf < depth = Nothing + | otherwise = Just $ hf { hfAccumulator = NE.fromList + $ NE.drop depth (hfAccumulator hf) } + +-- QuickCheck infrastructure +instance ( CoArbitrary a + , CoArbitrary b + , Arbitrary a + , Arbitrary b ) => Arbitrary (HistoricalFold a b) where + arbitrary = sized $ \n -> do + depth <- choose (1, n * 2) + acc <- arbitrary + fn <- arbitrary + -- depth > 1 => the result of new is Just.. + pure $ fromJust $ new fn depth acc + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000000..52a19ea835 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,18 @@ +import Test.Tasty +import qualified Test.Tasty.QuickCheck as QC + +import Data.Maybe (isNothing) + +import Model + +tests :: TestTree +tests = testGroup "Utxo index" [hfProperties] + +hfProperties :: TestTree +hfProperties = testGroup "Historical fold" [] + +prop_hfNewReturnsNothing :: (a -> b -> a) -> Int -> a -> Bool +prop_hfNewReturnsNothing fn depth acc = isNothing $ new fn depth acc + +main :: IO () +main = defaultMain tests diff --git a/utxo-index.cabal b/utxo-index.cabal new file mode 100644 index 0000000000..711dc33ff0 --- /dev/null +++ b/utxo-index.cabal @@ -0,0 +1,73 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.6. +-- +-- see: https://github.com/sol/hpack + +name: utxo-index +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/utxo-index#readme +bug-reports: https://github.com/githubuser/utxo-index/issues +author: Author name here +maintainer: example@example.com +copyright: 2022 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/utxo-index + +library + exposed-modules: + Lib + other-modules: + Paths_utxo_index + hs-source-dirs: + src + default-extensions: + ImportQualifiedPost + ExplicitForAll + build-depends: + base >=4.7 && <5 + default-language: Haskell2010 + +executable utxo-index-exe + main-is: Main.hs + other-modules: + Paths_utxo_index + hs-source-dirs: + app + default-extensions: + ImportQualifiedPost + ExplicitForAll + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , utxo-index + default-language: Haskell2010 + +test-suite utxo-index-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Model + Paths_utxo_index + hs-source-dirs: + test + default-extensions: + ImportQualifiedPost + ExplicitForAll + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4.7 && <5 + , tasty + , tasty-quickcheck + , utxo-index + default-language: Haskell2010 From 34d0cf8a8e9ed580b55a1ff4a852012ff68d609d Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Sun, 23 Jan 2022 20:19:26 +0200 Subject: [PATCH 02/62] Added a sanity check for cases where we pass in depth <= 0 --- package.yaml | 2 ++ test/Spec.hs | 20 ++++++++++++++++---- utxo-index.cabal | 6 ++++++ 3 files changed, 24 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index 8751eda17d..efb255ad43 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,8 @@ description: Please see the README on GitHub at = 4.7 && < 5 diff --git a/test/Spec.hs b/test/Spec.hs index 52a19ea835..307fadf979 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,16 +3,28 @@ import qualified Test.Tasty.QuickCheck as QC import Data.Maybe (isNothing) -import Model +import Test.QuickCheck (Blind (Blind), Fun (Fun), pattern Fn2, + NonPositive (NonPositive)) + +import Model (new) tests :: TestTree tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree -hfProperties = testGroup "Historical fold" [] +hfProperties = testGroup "Historical fold" + [ QC.testProperty "Negative or zero depth" $ prop_hfNewReturnsNothing @Int @Int + ] -prop_hfNewReturnsNothing :: (a -> b -> a) -> Int -> a -> Bool -prop_hfNewReturnsNothing fn depth acc = isNothing $ new fn depth acc +prop_hfNewReturnsNothing + :: Fun (a, b) a + -> NonPositive Int + -> a + -> Bool +prop_hfNewReturnsNothing + (Fn2 fn) + (NonPositive depth) + acc = isNothing $ new fn depth acc main :: IO () main = defaultMain tests diff --git a/utxo-index.cabal b/utxo-index.cabal index 711dc33ff0..1c278f2814 100644 --- a/utxo-index.cabal +++ b/utxo-index.cabal @@ -33,6 +33,8 @@ library default-extensions: ImportQualifiedPost ExplicitForAll + TypeApplications + PatternSynonyms build-depends: base >=4.7 && <5 default-language: Haskell2010 @@ -46,6 +48,8 @@ executable utxo-index-exe default-extensions: ImportQualifiedPost ExplicitForAll + TypeApplications + PatternSynonyms ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 @@ -63,6 +67,8 @@ test-suite utxo-index-test default-extensions: ImportQualifiedPost ExplicitForAll + TypeApplications + PatternSynonyms ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck From 8119c45088964548eb771445b82d3f6ba2a993d8 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Sun, 23 Jan 2022 20:23:42 +0200 Subject: [PATCH 03/62] When depth > 0 we should always be able to build something. --- test/Spec.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 307fadf979..0d3e0345f2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,10 @@ import Test.Tasty import qualified Test.Tasty.QuickCheck as QC -import Data.Maybe (isNothing) +import Data.Maybe (isNothing, isJust) import Test.QuickCheck (Blind (Blind), Fun (Fun), pattern Fn2, - NonPositive (NonPositive)) + NonPositive (NonPositive), Positive(Positive)) import Model (new) @@ -14,6 +14,7 @@ tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree hfProperties = testGroup "Historical fold" [ QC.testProperty "Negative or zero depth" $ prop_hfNewReturnsNothing @Int @Int + , QC.testProperty "Positive depth" $ prop_hfNewReturnsSomething @Int @Int ] prop_hfNewReturnsNothing @@ -26,5 +27,15 @@ prop_hfNewReturnsNothing (NonPositive depth) acc = isNothing $ new fn depth acc +prop_hfNewReturnsSomething + :: Fun (a, b) a + -> Positive Int + -> a + -> Bool +prop_hfNewReturnsSomething + (Fn2 fn) + (Positive depth) + acc = isJust $ new fn depth acc + main :: IO () main = defaultMain tests From b6ff9c4336bed7df8373e9528518853e7297445d Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 00:12:31 +0200 Subject: [PATCH 04/62] Added properties: * History length should always be less then HF depth. * Check that rewind returns Just/Nothing properly. --- test/Model.hs | 36 +++++++++++++++++++++++++++++------- test/Spec.hs | 49 +++++++++++++++++++++++++++++++++++++------------ 2 files changed, 66 insertions(+), 19 deletions(-) diff --git a/test/Model.hs b/test/Model.hs index 64e5756aeb..f752a5360c 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -1,5 +1,7 @@ module Model ( -- * Model data HistoricalFold + -- Should we provide access to these? + , hfDepth -- * Model functionality , new , insert @@ -11,13 +13,15 @@ module Model ( -- * Model data -- * QuickCheck instrumentation ) where +import Control.Monad (replicateM) import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust) import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, - choose, listOf, sized) + choose, chooseInt, frequency, listOf, + sized) -- | Model of a historical (we can go backwards) fold over a data set. @@ -27,12 +31,16 @@ data HistoricalFold a b = HistoricalFold , hfAccumulator :: NonEmpty a } +instance (Show a, Show b) => Show (HistoricalFold a b) where + show (HistoricalFold _ depth acc) = + show $ "HF " <> show depth <> " " <> show acc + -- | Operations over the historical folds. new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) new fn depth acc | depth <= 0 = Nothing - | otherwise = Just $ + | otherwise = Just $ HistoricalFold { hfFunction = fn , hfDepth = depth , hfAccumulator = acc :| [] @@ -40,7 +48,8 @@ new fn depth acc insert :: b -> HistoricalFold a b -> HistoricalFold a b insert v hf@(HistoricalFold fn depth acc@(hacc :| _)) = - -- TODO: forall hf v. historyLength (insert v hf) > 0 + -- forall hf v. historyLength (insert v hf) > 0 + -- Take will always return something non-null. hf { hfAccumulator = NE.fromList $ NE.take depth $ fn hacc v <| acc } @@ -54,7 +63,6 @@ historyLength :: HistoricalFold a b -> Int historyLength (HistoricalFold _ _ acc) = NE.length acc rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) --- TODO: Check all Nothing/Just cases. rewind depth hf | hfDepth hf < depth = Nothing | historyLength hf < depth = Nothing @@ -67,9 +75,23 @@ instance ( CoArbitrary a , Arbitrary a , Arbitrary b ) => Arbitrary (HistoricalFold a b) where arbitrary = sized $ \n -> do - depth <- choose (1, n * 2) + -- What happens when n is 0 or 1? + depth <- frequency [ (05, pure 1) + , (40, chooseInt (2, n + 2)) + , (40, chooseInt (n + 2, n * 2 + 2)) + ] + overflow <- chooseInt (depth, depth * 2) acc <- arbitrary fn <- arbitrary - -- depth > 1 => the result of new is Just.. - pure $ fromJust $ new fn depth acc + bs <- frequency [ (05, pure []) -- empty + , (50, arbitrary) -- randomized + , (30, replicateM (depth `div` 2) -- half filled + arbitrary) + , (10, replicateM overflow arbitrary) -- overfilled + , (05, replicateM depth arbitrary) -- exact + ] + -- Construction can only fail due to NonPositive depth + -- Tested with prop_hfNewReturns... + let newHf = fromJust $ new fn depth acc + pure $ insertL bs newHf diff --git a/test/Spec.hs b/test/Spec.hs index 0d3e0345f2..1fbcaeab8d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,20 +1,21 @@ import Test.Tasty -import qualified Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck -import Data.Maybe (isNothing, isJust) +import Data.Maybe (isJust, isNothing) -import Test.QuickCheck (Blind (Blind), Fun (Fun), pattern Fn2, - NonPositive (NonPositive), Positive(Positive)) - -import Model (new) +import Model tests :: TestTree tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree hfProperties = testGroup "Historical fold" - [ QC.testProperty "Negative or zero depth" $ prop_hfNewReturnsNothing @Int @Int - , QC.testProperty "Positive depth" $ prop_hfNewReturnsSomething @Int @Int + [ testProperty "New: Negative or zero depth" $ prop_hfNewReturnsNothing @Int @Int + , testProperty "New: Positive depth" $ prop_hfNewReturnsSomething @Int @Int + , testProperty "History length is always smaller than the max depth" $ + prop_historyLengthLEDepth @Int @Int + , testProperty "Rewind: Connection with `hfDepth`" $ + prop_rewindWithDepth @Int @Int ] prop_hfNewReturnsNothing @@ -23,9 +24,9 @@ prop_hfNewReturnsNothing -> a -> Bool prop_hfNewReturnsNothing - (Fn2 fn) + fn2 (NonPositive depth) - acc = isNothing $ new fn depth acc + acc = isNothing $ new (applyFun2 fn2) depth acc prop_hfNewReturnsSomething :: Fun (a, b) a @@ -33,9 +34,33 @@ prop_hfNewReturnsSomething -> a -> Bool prop_hfNewReturnsSomething - (Fn2 fn) + fn2 (Positive depth) - acc = isJust $ new fn depth acc + acc = isJust $ new (applyFun2 fn2) depth acc + +prop_rewindWithDepth + :: HistoricalFold a b + -> Property +prop_rewindWithDepth hf = + forAll (frequency [ (20, chooseInt (hfDepth hf + 1, (hfDepth hf + 1) * 2)) + , (30, chooseInt (historyLength hf + 1, hfDepth hf)) + , (50, chooseInt (1, historyLength hf)) ]) $ + \depth -> + cover 15 (depth > hfDepth hf) "Depth is larger than max depth." $ + cover 15 (depth <= hfDepth hf && depth > historyLength hf) + "Depth is lower than max but there is not enough data." $ + cover 40 (depth <= hfDepth hf && depth <= historyLength hf) + "Depth is properly set." $ + let newHF = rewind depth hf + in if depth > hfDepth hf || (depth > historyLength hf) + then property $ isNothing newHF + else property $ isJust newHF + +prop_historyLengthLEDepth + :: HistoricalFold a b + -> Property +prop_historyLengthLEDepth hf = + property $ historyLength hf <= hfDepth hf main :: IO () main = defaultMain tests From 27a1ed9415fd771901433a941d83b93c99a58ad0 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 11:05:06 +0200 Subject: [PATCH 05/62] Merge the two creation properties. --- test/Spec.hs | 32 +++++++++++++------------------- 1 file changed, 13 insertions(+), 19 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 1fbcaeab8d..06bdeb0ba7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,33 +10,27 @@ tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree hfProperties = testGroup "Historical fold" - [ testProperty "New: Negative or zero depth" $ prop_hfNewReturnsNothing @Int @Int - , testProperty "New: Positive depth" $ prop_hfNewReturnsSomething @Int @Int + [ testProperty "New: Positive or non-positive depth" $ prop_hfNewReturn @Int @Int , testProperty "History length is always smaller than the max depth" $ prop_historyLengthLEDepth @Int @Int , testProperty "Rewind: Connection with `hfDepth`" $ prop_rewindWithDepth @Int @Int ] -prop_hfNewReturnsNothing +prop_hfNewReturn :: Fun (a, b) a - -> NonPositive Int -> a - -> Bool -prop_hfNewReturnsNothing - fn2 - (NonPositive depth) - acc = isNothing $ new (applyFun2 fn2) depth acc - -prop_hfNewReturnsSomething - :: Fun (a, b) a - -> Positive Int - -> a - -> Bool -prop_hfNewReturnsSomething - fn2 - (Positive depth) - acc = isJust $ new (applyFun2 fn2) depth acc + -> Property +prop_hfNewReturn f acc = + forAll (frequency [ (50, chooseInt (-100, 0)) + , (50, chooseInt (1, 100)) ]) $ + \depth -> + cover 30 (depth < 0) "Negative depth" $ + cover 30 (depth >= 0) "Non negative depth" $ + let newHF = new (applyFun2 f) depth acc + in property $ if depth < 0 + then isNothing newHF + else isJust newHF prop_rewindWithDepth :: HistoricalFold a b From aac06818b0de1fb4316583de35065255ad318e82 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 21:04:54 +0200 Subject: [PATCH 06/62] Fix a gte bug for construction properties. --- test/Spec.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 06bdeb0ba7..9f2ce6f8ff 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -22,13 +22,14 @@ prop_hfNewReturn -> a -> Property prop_hfNewReturn f acc = - forAll (frequency [ (50, chooseInt (-100, 0)) + forAll (frequency [ (10, pure 0) + , (50, chooseInt (-100, 0)) , (50, chooseInt (1, 100)) ]) $ \depth -> cover 30 (depth < 0) "Negative depth" $ cover 30 (depth >= 0) "Non negative depth" $ let newHF = new (applyFun2 f) depth acc - in property $ if depth < 0 + in property $ if depth <= 0 then isNothing newHF else isJust newHF From e21ee27b46dac9a85ab7b56f53196621a196d432 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 22:56:33 +0200 Subject: [PATCH 07/62] Add github actions. --- .github/workflows/haskell-ci.yml | 183 +++++++++++++++++++++++++++++++ package.yaml | 3 + test/Model.hs | 6 +- test/Spec.hs | 17 ++- utxo-index.cabal | 1 + 5 files changed, 208 insertions(+), 2 deletions(-) create mode 100644 .github/workflows/haskell-ci.yml diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 0000000000..3b1052702d --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,183 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'utxo-index.cabal' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.14.1 +# +# REGENDATA ("0.14.1",["github","utxo-index.cabal"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-18.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-8.10.7 + compilerKind: ghc + compilerVersion: 8.10.7 + setup-method: ghcup + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz + echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v2 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_utxo_index="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/utxo-index-[0-9.]*')" + echo "PKGDIR_utxo_index=${PKGDIR_utxo_index}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_utxo_index}" >> cabal.project + echo "package utxo-index" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project + cat >> cabal.project <> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: cache + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: cabal check + run: | + cd ${PKGDIR_utxo_index} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all diff --git a/package.yaml b/package.yaml index efb255ad43..efb54a8f4b 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,9 @@ dependencies: library: source-dirs: src +verbatim: + Tested-With: GHC ==8.10.7 + executables: utxo-index-exe: main: Main.hs diff --git a/test/Model.hs b/test/Model.hs index f752a5360c..c2782cd5d2 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -8,6 +8,7 @@ module Model ( -- * Model data , view , historyLength , rewind + , sameHistory -- * Helpers , insertL -- * QuickCheck instrumentation @@ -36,7 +37,6 @@ instance (Show a, Show b) => Show (HistoricalFold a b) where show $ "HF " <> show depth <> " " <> show acc -- | Operations over the historical folds. - new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) new fn depth acc | depth <= 0 = Nothing @@ -69,6 +69,10 @@ rewind depth hf | otherwise = Just $ hf { hfAccumulator = NE.fromList $ NE.drop depth (hfAccumulator hf) } +sameHistory :: Eq a => HistoricalFold a b -> HistoricalFold a b -> Bool +sameHistory hl hr = + hfAccumulator hl == hfAccumulator hr + -- QuickCheck infrastructure instance ( CoArbitrary a , CoArbitrary b diff --git a/test/Spec.hs b/test/Spec.hs index 9f2ce6f8ff..6dd85d23b1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,7 @@ import Test.Tasty import Test.Tasty.QuickCheck -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust, isNothing, fromJust) import Model @@ -15,8 +15,11 @@ hfProperties = testGroup "Historical fold" prop_historyLengthLEDepth @Int @Int , testProperty "Rewind: Connection with `hfDepth`" $ prop_rewindWithDepth @Int @Int + -- , testProperty "Relationship between Insert/Rewind" $ + -- prop_InsertRewindInverse @Int @Int ] +-- | Properties of the `new` operation. prop_hfNewReturn :: Fun (a, b) a -> a @@ -33,6 +36,7 @@ prop_hfNewReturn f acc = then isNothing newHF else isJust newHF +-- | Properties of the connection between rewind and depth prop_rewindWithDepth :: HistoricalFold a b -> Property @@ -51,11 +55,22 @@ prop_rewindWithDepth hf = then property $ isNothing newHF else property $ isJust newHF +-- | Property that validates the HF data structure. prop_historyLengthLEDepth :: HistoricalFold a b -> Property prop_historyLengthLEDepth hf = property $ historyLength hf <= hfDepth hf +prop_InsertRewindInverse + :: Eq a + => HistoricalFold a b + -> [b] + -> Property +prop_InsertRewindInverse hf bs = + let bs' = take (hfDepth hf) bs -- limit the input to the depth. + hf' = rewind (length bs') $ insertL bs' hf + in property $ isJust hf' && fromJust hf' `sameHistory` hf + main :: IO () main = defaultMain tests diff --git a/utxo-index.cabal b/utxo-index.cabal index 1c278f2814..bfd1f7a476 100644 --- a/utxo-index.cabal +++ b/utxo-index.cabal @@ -18,6 +18,7 @@ build-type: Simple extra-source-files: README.md ChangeLog.md +Tested-With: GHC ==8.10.7 source-repository head type: git From 8416266632a4813e04ebe2653d7935246ab07dfa Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 23:03:27 +0200 Subject: [PATCH 08/62] Added category and synopsis to cabal config. --- package.yaml | 2 ++ utxo-index.cabal | 2 ++ 2 files changed, 4 insertions(+) diff --git a/package.yaml b/package.yaml index efb54a8f4b..010bc559aa 100644 --- a/package.yaml +++ b/package.yaml @@ -5,6 +5,8 @@ license: BSD3 author: "Author name here" maintainer: "example@example.com" copyright: "2022 Author name here" +category: "Testing" +synopsis: "Exercises in Algebra Driven Design" extra-source-files: - README.md diff --git a/utxo-index.cabal b/utxo-index.cabal index bfd1f7a476..529376613c 100644 --- a/utxo-index.cabal +++ b/utxo-index.cabal @@ -6,7 +6,9 @@ cabal-version: 1.12 name: utxo-index version: 0.1.0.0 +synopsis: Exercises in Algebra Driven Design description: Please see the README on GitHub at +category: Testing homepage: https://github.com/githubuser/utxo-index#readme bug-reports: https://github.com/githubuser/utxo-index/issues author: Author name here From 4475f3a1edb690590ebe62e5cdcf1004bf8d8f99 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 23:08:12 +0200 Subject: [PATCH 09/62] Add badge. --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index edf36c2c48..f2ff5a332a 100644 --- a/README.md +++ b/README.md @@ -1 +1,3 @@ # utxo-index + +[![Haskell-CI](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml) From f33fbbb85e184ae0752c335efb554b2ee3fdeec4 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 24 Jan 2022 23:12:57 +0200 Subject: [PATCH 10/62] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f2ff5a332a..4f3fdd1bd8 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ # utxo-index -[![Haskell-CI](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml) +[![Haskell-CI](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml) From 9c9b3e516a0e183be2923416008fbf405e19657c Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 25 Jan 2022 00:32:27 +0200 Subject: [PATCH 11/62] Rewind cannot be called if (hfDepth hf == 1) --- test/Model.hs | 23 +++++++++++++++-------- test/Spec.hs | 27 +++++++++++++++++---------- 2 files changed, 32 insertions(+), 18 deletions(-) diff --git a/test/Model.hs b/test/Model.hs index c2782cd5d2..305cede569 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -8,15 +8,15 @@ module Model ( -- * Model data , view , historyLength , rewind - , sameHistory + , matchesHistory -- * Helpers , insertL -- * QuickCheck instrumentation ) where import Control.Monad (replicateM) -import Data.List (foldl') -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List (foldl', isInfixOf) +import Data.List.NonEmpty (NonEmpty (..), (<|), toList) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust) @@ -24,6 +24,8 @@ import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, choose, chooseInt, frequency, listOf, sized) +import Debug.Trace qualified as Debug + -- | Model of a historical (we can go backwards) fold over a data set. data HistoricalFold a b = HistoricalFold @@ -34,7 +36,7 @@ data HistoricalFold a b = HistoricalFold instance (Show a, Show b) => Show (HistoricalFold a b) where show (HistoricalFold _ depth acc) = - show $ "HF " <> show depth <> " " <> show acc + show $ "HistoricalFold { hfDepth = " <> show depth <> ", hfAccumulator = " <> show (toList acc) <> " }" -- | Operations over the historical folds. new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) @@ -64,14 +66,19 @@ historyLength (HistoricalFold _ _ acc) = NE.length acc rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) rewind depth hf - | hfDepth hf < depth = Nothing + | hfDepth hf <= depth = Nothing | historyLength hf < depth = Nothing | otherwise = Just $ hf { hfAccumulator = NE.fromList $ NE.drop depth (hfAccumulator hf) } -sameHistory :: Eq a => HistoricalFold a b -> HistoricalFold a b -> Bool -sameHistory hl hr = - hfAccumulator hl == hfAccumulator hr +matchesHistory :: (Show a, Eq a) => HistoricalFold a b -> HistoricalFold a b -> Bool +matchesHistory hl hr = + let hlAccumulator = toList $ hfAccumulator hl + hrAccumulator = toList $ hfAccumulator hr + in Debug.trace (show hlAccumulator <> " vs " <> show hrAccumulator <> " -> " <> show (hrAccumulator == hlAccumulator)) $ + hlAccumulator `isInfixOf` hrAccumulator + || hrAccumulator `isInfixOf` hlAccumulator + || hrAccumulator == hlAccumulator -- QuickCheck infrastructure instance ( CoArbitrary a diff --git a/test/Spec.hs b/test/Spec.hs index 6dd85d23b1..117c2ed9fa 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,16 +5,19 @@ import Data.Maybe (isJust, isNothing, fromJust) import Model +import Debug.Trace qualified as Debug + tests :: TestTree tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree hfProperties = testGroup "Historical fold" - [ testProperty "New: Positive or non-positive depth" $ prop_hfNewReturn @Int @Int + [ testProperty "New: Positive or non-positive depth" $ + withMaxSuccess 10000 $ prop_hfNewReturn @Int @Int , testProperty "History length is always smaller than the max depth" $ - prop_historyLengthLEDepth @Int @Int + withMaxSuccess 10000 $ prop_historyLengthLEDepth @Int @Int , testProperty "Rewind: Connection with `hfDepth`" $ - prop_rewindWithDepth @Int @Int + withMaxSuccess 10000 $ prop_rewindWithDepth @Int @Int -- , testProperty "Relationship between Insert/Rewind" $ -- prop_InsertRewindInverse @Int @Int ] @@ -37,12 +40,14 @@ prop_hfNewReturn f acc = else isJust newHF -- | Properties of the connection between rewind and depth +-- Note: Cannot rewind if (hfDepth hf == 1) prop_rewindWithDepth :: HistoricalFold a b -> Property prop_rewindWithDepth hf = - forAll (frequency [ (20, chooseInt (hfDepth hf + 1, (hfDepth hf + 1) * 2)) - , (30, chooseInt (historyLength hf + 1, hfDepth hf)) + hfDepth hf >= 2 ==> + forAll (frequency [ (20, chooseInt (hfDepth hf, hfDepth hf * 2)) + , (30, chooseInt (historyLength hf + 1, hfDepth hf - 1)) , (50, chooseInt (1, historyLength hf)) ]) $ \depth -> cover 15 (depth > hfDepth hf) "Depth is larger than max depth." $ @@ -51,7 +56,7 @@ prop_rewindWithDepth hf = cover 40 (depth <= hfDepth hf && depth <= historyLength hf) "Depth is properly set." $ let newHF = rewind depth hf - in if depth > hfDepth hf || (depth > historyLength hf) + in if depth > (hfDepth hf - 1) || (depth > historyLength hf) then property $ isNothing newHF else property $ isJust newHF @@ -63,14 +68,16 @@ prop_historyLengthLEDepth hf = property $ historyLength hf <= hfDepth hf prop_InsertRewindInverse - :: Eq a + :: (Show a, Eq a) => HistoricalFold a b -> [b] -> Property prop_InsertRewindInverse hf bs = - let bs' = take (hfDepth hf) bs -- limit the input to the depth. - hf' = rewind (length bs') $ insertL bs' hf - in property $ isJust hf' && fromJust hf' `sameHistory` hf + hfDepth hf >= 2 ==> -- rewind does not make sense for lesser depths. + let limit = min (length bs) (hfDepth hf - 1) -- Make the rewind legal + size = historyLength hf + hf' = rewind limit $ insertL bs hf + in property $ Debug.trace ("Limit: " <> show limit) $ isJust hf' && fromJust hf' `matchesHistory` hf main :: IO () main = defaultMain tests From 0a48bb3680a2029ebfa212f998e245d257113f11 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 25 Jan 2022 01:34:45 +0200 Subject: [PATCH 12/62] Added a relationship between insert and rewind. --- test/Model.hs | 3 +-- test/Spec.hs | 26 +++++++++++++++----------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/test/Model.hs b/test/Model.hs index 305cede569..02a48bc709 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -75,8 +75,7 @@ matchesHistory :: (Show a, Eq a) => HistoricalFold a b -> HistoricalFold a b -> matchesHistory hl hr = let hlAccumulator = toList $ hfAccumulator hl hrAccumulator = toList $ hfAccumulator hr - in Debug.trace (show hlAccumulator <> " vs " <> show hrAccumulator <> " -> " <> show (hrAccumulator == hlAccumulator)) $ - hlAccumulator `isInfixOf` hrAccumulator + in hlAccumulator `isInfixOf` hrAccumulator || hrAccumulator `isInfixOf` hlAccumulator || hrAccumulator == hlAccumulator diff --git a/test/Spec.hs b/test/Spec.hs index 117c2ed9fa..d70aeeaadd 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,14 +12,14 @@ tests = testGroup "Utxo index" [hfProperties] hfProperties :: TestTree hfProperties = testGroup "Historical fold" - [ testProperty "New: Positive or non-positive depth" $ + [ testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ prop_hfNewReturn @Int @Int , testProperty "History length is always smaller than the max depth" $ withMaxSuccess 10000 $ prop_historyLengthLEDepth @Int @Int , testProperty "Rewind: Connection with `hfDepth`" $ withMaxSuccess 10000 $ prop_rewindWithDepth @Int @Int - -- , testProperty "Relationship between Insert/Rewind" $ - -- prop_InsertRewindInverse @Int @Int + , testProperty "Relationship between Insert/Rewind" $ + withMaxSuccess 10000 $ prop_InsertRewindInverse @Int @Int ] -- | Properties of the `new` operation. @@ -68,16 +68,20 @@ prop_historyLengthLEDepth hf = property $ historyLength hf <= hfDepth hf prop_InsertRewindInverse - :: (Show a, Eq a) + :: (Show a, Show b, Arbitrary b, Eq a) => HistoricalFold a b - -> [b] -> Property -prop_InsertRewindInverse hf bs = - hfDepth hf >= 2 ==> -- rewind does not make sense for lesser depths. - let limit = min (length bs) (hfDepth hf - 1) -- Make the rewind legal - size = historyLength hf - hf' = rewind limit $ insertL bs hf - in property $ Debug.trace ("Limit: " <> show limit) $ isJust hf' && fromJust hf' `matchesHistory` hf +prop_InsertRewindInverse hf = + -- rewind does not make sense for lesser depths. + hfDepth hf >= 2 ==> + -- if the history is not fully re-written, then we can get a common + -- prefix after the insert/rewind play. We need input which is less + -- than `hfDepth hf` + forAll (resize (hfDepth hf - 1) arbitrary) $ + \bs -> + let hf' = rewind (length bs) $ insertL bs hf + in property $ isJust hf' && fromJust hf' `matchesHistory` hf + main :: IO () main = defaultMain tests From b49317430a5ebc061a7fc59fe81f9a97e4778baf Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 26 Jan 2022 10:27:08 +0200 Subject: [PATCH 13/62] Connection between insert and folding/history length --- test/Model.hs | 2 ++ test/Spec.hs | 34 ++++++++++++++++++++++++++++++++-- 2 files changed, 34 insertions(+), 2 deletions(-) diff --git a/test/Model.hs b/test/Model.hs index 02a48bc709..cd7cb29d0e 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -2,6 +2,8 @@ module Model ( -- * Model data HistoricalFold -- Should we provide access to these? , hfDepth + , hfAccumulator + , hfFunction -- * Model functionality , new , insert diff --git a/test/Spec.hs b/test/Spec.hs index d70aeeaadd..675da4498c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,12 @@ import Test.Tasty import Test.Tasty.QuickCheck -import Data.Maybe (isJust, isNothing, fromJust) +import Data.List (foldl') +import Data.Maybe (fromJust, isJust, isNothing) import Model -import Debug.Trace qualified as Debug +import qualified Debug.Trace as Debug tests :: TestTree tests = testGroup "Utxo index" [hfProperties] @@ -20,6 +21,10 @@ hfProperties = testGroup "Historical fold" withMaxSuccess 10000 $ prop_rewindWithDepth @Int @Int , testProperty "Relationship between Insert/Rewind" $ withMaxSuccess 10000 $ prop_InsertRewindInverse @Int @Int + , testProperty "Insert is folding the structure" $ + withMaxSuccess 10000 $ prop_InsertFolds @Int @Int + , testProperty "Insert is increasing the length unless overflowing" $ + withMaxSuccess 10000 $ prop_InsertHistoryLength @Int @Int ] -- | Properties of the `new` operation. @@ -67,6 +72,7 @@ prop_historyLengthLEDepth prop_historyLengthLEDepth hf = property $ historyLength hf <= hfDepth hf +-- | Relation between Rewind and Inverse prop_InsertRewindInverse :: (Show a, Show b, Arbitrary b, Eq a) => HistoricalFold a b @@ -82,6 +88,30 @@ prop_InsertRewindInverse hf = let hf' = rewind (length bs) $ insertL bs hf in property $ isJust hf' && fromJust hf' `matchesHistory` hf +-- | Generally this would not be a good property since it is very coupled +-- to the implementation, but it will be useful when trying to certify that +-- another implmentation is confirming. +prop_InsertFolds + :: (Eq a, Show a) + => HistoricalFold a b + -> [b] + -> Property +prop_InsertFolds hf bs = + view (insertL bs hf) === + foldl' (hfFunction hf) (view hf) bs + +prop_InsertHistoryLength + :: HistoricalFold a b + -> b + -> Property +prop_InsertHistoryLength hf b = + let initialLength = historyLength hf + finalLength = historyLength (insert b hf) + in cover 10 (initialLength == hfDepth hf) "Overflowing" $ + cover 30 (initialLength < hfDepth hf) "Not filled" $ + if initialLength == hfDepth hf + then finalLength === initialLength + else finalLength === initialLength + 1 main :: IO () main = defaultMain tests From c01baa431920d965d2975df2006045fde5556bb7 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 4 Feb 2022 14:54:33 +0200 Subject: [PATCH 14/62] Added a quickspec signature. --- app/Main.hs | 4 +--- package.yaml | 14 +++---------- src/Lib.hs | 6 ------ stack.yaml | 4 +++- stack.yaml.lock | 16 +++++++++++++- test/Model.hs | 54 ++++++++++++++++++++++++++++++++++++++++++++---- test/Spec.hs | 5 ++++- utxo-index.cabal | 24 ++++++--------------- 8 files changed, 82 insertions(+), 45 deletions(-) delete mode 100644 src/Lib.hs diff --git a/app/Main.hs b/app/Main.hs index de1c1ab35c..f7090c2764 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,4 @@ module Main where -import Lib - main :: IO () -main = someFunc +main = putStrLn "Hello world!" diff --git a/package.yaml b/package.yaml index 010bc559aa..ab77bba5e9 100644 --- a/package.yaml +++ b/package.yaml @@ -26,6 +26,7 @@ default-extensions: - ExplicitForAll - TypeApplications - PatternSynonyms + - DeriveGeneric dependencies: - base >= 4.7 && < 5 @@ -36,17 +37,6 @@ library: verbatim: Tested-With: GHC ==8.10.7 -executables: - utxo-index-exe: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - utxo-index - tests: utxo-index-test: main: Spec.hs @@ -58,5 +48,7 @@ tests: dependencies: - utxo-index - QuickCheck + - quickspec - tasty - tasty-quickcheck + - containers diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index d36ff2714d..0000000000 --- a/src/Lib.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Lib - ( someFunc - ) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/stack.yaml b/stack.yaml index 33b9472fa1..46d9939013 100644 --- a/stack.yaml +++ b/stack.yaml @@ -40,7 +40,9 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] +extra-deps: +- quickspec-2.1.5@sha256:1d1cc020fa9075cb5fafd4056fe1d930d5763b954fa8200e57ce6aba057544b2,3557 +- twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index 9b8df1d045..4e4a06c2f8 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,7 +3,21 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + pantry-tree: + sha256: 36e7cd88a0fe800a0b0ea216c0c3ea96db02e25fd34ef53653f6d5008730476c + size: 3032 + hackage: quickspec-2.1.5@sha256:1d1cc020fa9075cb5fafd4056fe1d930d5763b954fa8200e57ce6aba057544b2,3557 + original: + hackage: quickspec-2.1.5@sha256:1d1cc020fa9075cb5fafd4056fe1d930d5763b954fa8200e57ce6aba057544b2,3557 +- completed: + pantry-tree: + sha256: 0356be78a4720251536932d2253f75eb1f97b26c61260e566b5e8e05642d5349 + size: 1487 + hackage: twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 + original: + hackage: twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 snapshots: - completed: sha256: f9970d6f25c63e3e4265aa8e9c69a047ba8919d1107e4996bdd7555b75aad0eb diff --git a/test/Model.hs b/test/Model.hs index cd7cb29d0e..133310bc9c 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} + module Model ( -- * Model data HistoricalFold -- Should we provide access to these? @@ -13,28 +17,35 @@ module Model ( -- * Model data , matchesHistory -- * Helpers , insertL - -- * QuickCheck instrumentation + -- * QuickSpec + , hfSignature ) where import Control.Monad (replicateM) import Data.List (foldl', isInfixOf) -import Data.List.NonEmpty (NonEmpty (..), (<|), toList) +import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) import qualified Data.List.NonEmpty as NE +import Data.Map (Map) import Data.Maybe (fromJust) +import GHC.Generics +import QuickSpec import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, choose, chooseInt, frequency, listOf, sized) -import Debug.Trace qualified as Debug +import Types (Address, Tx, TxId, Value) + +import qualified Debug.Trace as Debug -- | Model of a historical (we can go backwards) fold over a data set. +-- Should we make `b` a monoid? data HistoricalFold a b = HistoricalFold { hfFunction :: a -> b -> a , hfDepth :: Int , hfAccumulator :: NonEmpty a - } + } deriving (Typeable) instance (Show a, Show b) => Show (HistoricalFold a b) where show (HistoricalFold _ depth acc) = @@ -81,6 +92,8 @@ matchesHistory hl hr = || hrAccumulator `isInfixOf` hlAccumulator || hrAccumulator == hlAccumulator +type UtxoIndex a = HistoricalFold Tx a + -- QuickCheck infrastructure instance ( CoArbitrary a , CoArbitrary b @@ -107,3 +120,36 @@ instance ( CoArbitrary a let newHf = fromJust $ new fn depth acc pure $ insertL bs newHf +-- QuickSpec infrastructure +data HFObs a = HFObs + { hfoDepth :: Int + , hfoAccumulator :: NonEmpty a + } deriving (Eq, Ord, Typeable) + +newtype HFIns a b = HFIns [b] + deriving (Eq, Ord, Typeable) + +instance Arbitrary b => Arbitrary (HFIns a b) where + arbitrary = HFIns <$> listOf arbitrary + +instance ( Ord a + , Arbitrary a + , Arbitrary b + , CoArbitrary a + , CoArbitrary b ) => Observe (HistoricalFold a b) (HFObs a) (HFIns a b) where + observe hf (HFIns bs) = + let newHF = insertL bs hf + in HFObs { hfoDepth = hfDepth newHF + , hfoAccumulator = hfAccumulator newHF + } + +hfSignature :: [Sig] +hfSignature = + [ monoTypeObserve (Proxy :: Proxy (HFIns Int String)) + , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) + , con "insert" (insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) + , con "view" (view :: HistoricalFold Int String -> Int) + , con "historyLength" (historyLength :: HistoricalFold Int String -> Int) + , con "rewind" (rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) + , withMaxTermSize 4 + ] diff --git a/test/Spec.hs b/test/Spec.hs index 675da4498c..0fcee8b677 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,6 @@ import Test.Tasty import Test.Tasty.QuickCheck +import QuickSpec import Data.List (foldl') import Data.Maybe (fromJust, isJust, isNothing) @@ -114,4 +115,6 @@ prop_InsertHistoryLength hf b = else finalLength === initialLength + 1 main :: IO () -main = defaultMain tests +main = do + quickSpec hfSignature + defaultMain tests diff --git a/utxo-index.cabal b/utxo-index.cabal index 529376613c..fd9dceed57 100644 --- a/utxo-index.cabal +++ b/utxo-index.cabal @@ -28,7 +28,8 @@ source-repository head library exposed-modules: - Lib + Fingertree + Types other-modules: Paths_utxo_index hs-source-dirs: @@ -38,27 +39,11 @@ library ExplicitForAll TypeApplications PatternSynonyms + DeriveGeneric build-depends: base >=4.7 && <5 default-language: Haskell2010 -executable utxo-index-exe - main-is: Main.hs - other-modules: - Paths_utxo_index - hs-source-dirs: - app - default-extensions: - ImportQualifiedPost - ExplicitForAll - TypeApplications - PatternSynonyms - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , utxo-index - default-language: Haskell2010 - test-suite utxo-index-test type: exitcode-stdio-1.0 main-is: Spec.hs @@ -72,10 +57,13 @@ test-suite utxo-index-test ExplicitForAll TypeApplications PatternSynonyms + DeriveGeneric ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck , base >=4.7 && <5 + , containers + , quickspec , tasty , tasty-quickcheck , utxo-index From 83716149ccadeee680b17f15b98d9f5e81694ee7 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 15 Feb 2022 17:29:13 +0200 Subject: [PATCH 15/62] Rename package --- .github/workflows/haskell-ci.yml | 16 +++++++-------- .gitignore | 3 ++- README.md | 4 ++-- app/Main.hs | 4 ---- utxo-index.cabal => hysterical-screams.cabal | 21 +++++++++----------- package.yaml | 10 +++++----- test/Model.hs | 4 ---- test/Spec.hs | 3 +-- 8 files changed, 27 insertions(+), 38 deletions(-) delete mode 100644 app/Main.hs rename utxo-index.cabal => hysterical-screams.cabal (76%) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 3b1052702d..fb8becd731 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ # This GitHub workflow config has been generated by a script via # -# haskell-ci 'github' 'utxo-index.cabal' +# haskell-ci 'github' 'hysterical-screams.cabal' # # To regenerate the script (for example after adjusting tested-with) run # @@ -10,7 +10,7 @@ # # version: 0.14.1 # -# REGENDATA ("0.14.1",["github","utxo-index.cabal"]) +# REGENDATA ("0.14.1",["github","hysterical-screams.cabal"]) # name: Haskell-CI on: @@ -134,17 +134,17 @@ jobs: find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - name: generate cabal.project run: | - PKGDIR_utxo_index="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/utxo-index-[0-9.]*')" - echo "PKGDIR_utxo_index=${PKGDIR_utxo_index}" >> "$GITHUB_ENV" + PKGDIR_hysterical_screams="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hysterical-screams-[0-9.]*')" + echo "PKGDIR_hysterical_screams=${PKGDIR_hysterical_screams}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local - echo "packages: ${PKGDIR_utxo_index}" >> cabal.project - echo "package utxo-index" >> cabal.project + echo "packages: ${PKGDIR_hysterical_screams}" >> cabal.project + echo "package hysterical-screams" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(hysterical-screams)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -172,7 +172,7 @@ jobs: $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: cabal check run: | - cd ${PKGDIR_utxo_index} || false + cd ${PKGDIR_hysterical_screams} || false ${CABAL} -vnormal check - name: haddock run: | diff --git a/.gitignore b/.gitignore index c368d453bc..e909f1e190 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ -*~ \ No newline at end of file +dist-newstyle/ +*~ diff --git a/README.md b/README.md index 4f3fdd1bd8..173a0df221 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ -# utxo-index +# historical-streams -[![Haskell-CI](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/raduom/utxo-index/actions/workflows/haskell-ci.yml) +[![Haskell-CI](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml) diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index f7090c2764..0000000000 --- a/app/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "Hello world!" diff --git a/utxo-index.cabal b/hysterical-screams.cabal similarity index 76% rename from utxo-index.cabal rename to hysterical-screams.cabal index fd9dceed57..ba43d66fe4 100644 --- a/utxo-index.cabal +++ b/hysterical-screams.cabal @@ -4,13 +4,13 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -name: utxo-index +name: hysterical-screams version: 0.1.0.0 synopsis: Exercises in Algebra Driven Design -description: Please see the README on GitHub at +description: Please see the README on GitHub at category: Testing -homepage: https://github.com/githubuser/utxo-index#readme -bug-reports: https://github.com/githubuser/utxo-index/issues +homepage: https://github.com/githubuser/hysterical-screams#readme +bug-reports: https://github.com/githubuser/hysterical-screams/issues author: Author name here maintainer: example@example.com copyright: 2022 Author name here @@ -24,14 +24,11 @@ Tested-With: GHC ==8.10.7 source-repository head type: git - location: https://github.com/githubuser/utxo-index + location: https://github.com/githubuser/hysterical-screams library - exposed-modules: - Fingertree - Types other-modules: - Paths_utxo_index + Paths_hysterical_screams hs-source-dirs: src default-extensions: @@ -44,12 +41,12 @@ library base >=4.7 && <5 default-language: Haskell2010 -test-suite utxo-index-test +test-suite hysterical-screams-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Model - Paths_utxo_index + Paths_hysterical_screams hs-source-dirs: test default-extensions: @@ -63,8 +60,8 @@ test-suite utxo-index-test QuickCheck , base >=4.7 && <5 , containers + , hysterical-screams , quickspec , tasty , tasty-quickcheck - , utxo-index default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index ab77bba5e9..cb4495348e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,6 +1,6 @@ -name: utxo-index +name: hysterical-screams version: 0.1.0.0 -github: "githubuser/utxo-index" +github: "githubuser/hysterical-screams" license: BSD3 author: "Author name here" maintainer: "example@example.com" @@ -19,7 +19,7 @@ extra-source-files: # To avoid duplicated efforts in documentation and dealing with the # complications of embedding Haddock markup inside cabal files, it is # common to point users to the README.md file. -description: Please see the README on GitHub at +description: Please see the README on GitHub at default-extensions: - ImportQualifiedPost @@ -38,7 +38,7 @@ verbatim: Tested-With: GHC ==8.10.7 tests: - utxo-index-test: + hysterical-screams-test: main: Spec.hs source-dirs: test ghc-options: @@ -46,7 +46,7 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: - - utxo-index + - hysterical-screams - QuickCheck - quickspec - tasty diff --git a/test/Model.hs b/test/Model.hs index 133310bc9c..6204ec0578 100644 --- a/test/Model.hs +++ b/test/Model.hs @@ -34,8 +34,6 @@ import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, choose, chooseInt, frequency, listOf, sized) -import Types (Address, Tx, TxId, Value) - import qualified Debug.Trace as Debug -- | Model of a historical (we can go backwards) fold over a data set. @@ -92,8 +90,6 @@ matchesHistory hl hr = || hrAccumulator `isInfixOf` hlAccumulator || hrAccumulator == hlAccumulator -type UtxoIndex a = HistoricalFold Tx a - -- QuickCheck infrastructure instance ( CoArbitrary a , CoArbitrary b diff --git a/test/Spec.hs b/test/Spec.hs index 0fcee8b677..aae285161a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -115,6 +115,5 @@ prop_InsertHistoryLength hf b = else finalLength === initialLength + 1 main :: IO () -main = do - quickSpec hfSignature +main = defaultMain tests From 489cebfb1c6d863f06a50c0f235cc0f326b3ca98 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 15 Feb 2022 18:24:17 +0200 Subject: [PATCH 16/62] Add a stored index. --- hysterical-screams.cabal | 2 ++ src/Index/Stored.hs | 1 + 2 files changed, 3 insertions(+) create mode 100644 src/Index/Stored.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index ba43d66fe4..093c56f933 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -27,6 +27,8 @@ source-repository head location: https://github.com/githubuser/hysterical-screams library + exposed-modules: + Index.Stored other-modules: Paths_hysterical_screams hs-source-dirs: diff --git a/src/Index/Stored.hs b/src/Index/Stored.hs new file mode 100644 index 0000000000..cbde46d2ea --- /dev/null +++ b/src/Index/Stored.hs @@ -0,0 +1 @@ +module Index.Stored where From ea89577bb3444a6b3e7d57754b92c914851eb521 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 17 Feb 2022 21:47:12 +0200 Subject: [PATCH 17/62] Rename Model to HistoricalFold. --- hysterical-screams.cabal | 3 +- src/Index/HistoricalFold.hs | 78 +++++++++++++++++++ src/Index/Stored.hs | 66 +++++++++++++++- test/HistoricalFold.hs | 82 ++++++++++++++++++++ test/Model.hs | 151 ------------------------------------ test/Spec.hs | 7 +- 6 files changed, 230 insertions(+), 157 deletions(-) create mode 100644 src/Index/HistoricalFold.hs create mode 100644 test/HistoricalFold.hs delete mode 100644 test/Model.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 093c56f933..5089560cb2 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -28,6 +28,7 @@ source-repository head library exposed-modules: + Index.HistoricalFold Index.Stored other-modules: Paths_hysterical_screams @@ -47,7 +48,7 @@ test-suite hysterical-screams-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Model + HistoricalFold Paths_hysterical_screams hs-source-dirs: test diff --git a/src/Index/HistoricalFold.hs b/src/Index/HistoricalFold.hs new file mode 100644 index 0000000000..c7cba05a85 --- /dev/null +++ b/src/Index/HistoricalFold.hs @@ -0,0 +1,78 @@ +module Index.HistoricalFold + ( HistoricalFold + -- * Accessors + , hfDepth + , hfAccumulator + , hfFunction + -- * Functions + , new + , insert + , view + , historyLength + , rewind + , matchesHistory + -- * Helpers + , insertL + ) where + +import Data.List (foldl', isInfixOf) +import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) +import qualified Data.List.NonEmpty as NE +import Data.Typeable (Typeable) +import GHC.Generics + +-- | Model of a historical (we can go backwards) fold over a data set. + +-- Should we make `b` a monoid? +data HistoricalFold a b = HistoricalFold + { hfFunction :: a -> b -> a + , hfDepth :: Int + , hfAccumulator :: NonEmpty a + } deriving (Typeable) + +instance (Show a, Show b) => Show (HistoricalFold a b) where + show (HistoricalFold _ depth acc) = + show $ "HistoricalFold { hfDepth = " <> show depth <> ", hfAccumulator = " <> show (toList acc) <> " }" + +-- | Operations over the historical folds. +new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) +new fn depth acc + | depth <= 0 = Nothing + | otherwise = Just $ + HistoricalFold { hfFunction = fn + , hfDepth = depth + , hfAccumulator = acc :| [] + } + +insert :: b -> HistoricalFold a b -> HistoricalFold a b +insert v hf@(HistoricalFold fn depth acc@(hacc :| _)) = + -- forall hf v. historyLength (insert v hf) > 0 + -- Take will always return something non-null. + hf { hfAccumulator = NE.fromList $ NE.take depth $ + fn hacc v <| acc } + +insertL :: [b] -> HistoricalFold a b -> HistoricalFold a b +insertL bs hf = foldl' (flip insert) hf bs + +view :: HistoricalFold a b -> a +view (HistoricalFold _ _ (hacc :| _)) = hacc + +historyLength :: HistoricalFold a b -> Int +historyLength (HistoricalFold _ _ acc) = NE.length acc + +rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) +rewind depth hf + | hfDepth hf <= depth = Nothing + | historyLength hf < depth = Nothing + | otherwise = Just $ hf { hfAccumulator = NE.fromList + $ NE.drop depth (hfAccumulator hf) } + +matchesHistory :: (Show a, Eq a) => HistoricalFold a b -> HistoricalFold a b -> Bool +matchesHistory hl hr = + let hlAccumulator = toList $ hfAccumulator hl + hrAccumulator = toList $ hfAccumulator hr + in hlAccumulator `isInfixOf` hrAccumulator + || hrAccumulator `isInfixOf` hlAccumulator + || hrAccumulator == hlAccumulator + + diff --git a/src/Index/Stored.hs b/src/Index/Stored.hs index cbde46d2ea..1c39487b85 100644 --- a/src/Index/Stored.hs +++ b/src/Index/Stored.hs @@ -1 +1,65 @@ -module Index.Stored where +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Index.Stored + ( StoredIndex + , new + , insert + , insertL + , view + , historyLength + , rewind + ) where + +import Data.Foldable (foldlM) + +data StoredIndex m a e = StoredIndex + { siHandle :: m a + , siEvents :: [e] + , siDepth :: Int + , siStore :: a -> [e] -> m a + } + +storeEventsThreshold :: Int +storeEventsThreshold = 3 + +new :: Monad m => (a -> [e] -> m a) -> Int -> a -> m (Maybe (StoredIndex m a e)) +new store depth acc + | depth <= 0 = pure Nothing + | otherwise = pure $ Just $ StoredIndex + { siHandle = pure acc + , siEvents = [] + , siDepth = depth + , siStore = store + } + +insert :: Monad m => e -> StoredIndex m a e -> m (StoredIndex m a e) +insert e ix@StoredIndex{ siEvents, siDepth } = do + ix' <- if length siEvents > siDepth * storeEventsThreshold + then mergeEvents ix + else pure ix + pure ix' { siEvents = e : siEvents } + +mergeEvents :: Monad m => StoredIndex m a e -> m (StoredIndex m a e) +mergeEvents ix@StoredIndex { siEvents, siDepth, siStore, siHandle } = do + let liveEs = take siDepth siEvents + storedEs = drop siDepth siEvents + h <- siHandle + nextStore <- siStore h storedEs + pure $ ix { siHandle = pure nextStore + , siEvents = liveEs + } + +insertL :: Monad m => [e] -> StoredIndex m a e -> m (StoredIndex m a e) +insertL es ix = foldlM (flip insert) ix es + +view :: StoredIndex m a e -> m a +view = siHandle + +historyLength :: StoredIndex m a e -> Int +historyLength StoredIndex { siDepth, siEvents } = + min siDepth (length siEvents) + +rewind :: Int -> StoredIndex m a e -> StoredIndex m a e +rewind n ix@StoredIndex { siEvents } = + ix { siEvents = drop n siEvents } diff --git a/test/HistoricalFold.hs b/test/HistoricalFold.hs new file mode 100644 index 0000000000..7db589bd16 --- /dev/null +++ b/test/HistoricalFold.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HistoricalFold + ( hfSignature + ) where + +import Control.Monad (replicateM) +import Data.Map (Map) +import Data.Maybe (fromJust) +import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) +import GHC.Generics + +import QuickSpec +import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, + choose, chooseInt, frequency, listOf, + sized) + +import Index.HistoricalFold (HistoricalFold) +import Index.HistoricalFold qualified as HF + +import qualified Debug.Trace as Debug + +-- QuickCheck infrastructure +instance ( CoArbitrary a + , CoArbitrary b + , Arbitrary a + , Arbitrary b ) => Arbitrary (HistoricalFold a b) where + arbitrary = sized $ \n -> do + -- What happens when n is 0 or 1? + depth <- frequency [ (05, pure 1) + , (40, chooseInt (2, n + 2)) + , (40, chooseInt (n + 2, n * 2 + 2)) + ] + overflow <- chooseInt (depth, depth * 2) + acc <- arbitrary + fn <- arbitrary + bs <- frequency [ (05, pure []) -- empty + , (50, arbitrary) -- randomized + , (30, replicateM (depth `div` 2) -- half filled + arbitrary) + , (10, replicateM overflow arbitrary) -- overfilled + , (05, replicateM depth arbitrary) -- exact + ] + -- Construction can only fail due to NonPositive depth + -- Tested with prop_hfNewReturns... + let newHf = fromJust $ HF.new fn depth acc + pure $ HF.insertL bs newHf + +-- QuickSpec infrastructure +data HFObs a = HFObs + { hfoDepth :: Int + , hfoAccumulator :: NonEmpty a + } deriving (Eq, Ord, Typeable) + +newtype HFIns a b = HFIns [b] + deriving (Eq, Ord, Typeable) + +instance Arbitrary b => Arbitrary (HFIns a b) where + arbitrary = HFIns <$> listOf arbitrary + +instance ( Ord a + , Arbitrary a + , Arbitrary b + , CoArbitrary a + , CoArbitrary b ) => Observe (HistoricalFold a b) (HFObs a) (HFIns a b) where + observe hf (HFIns bs) = + let newHF = HF.insertL bs hf + in HFObs { hfoDepth = HF.hfDepth newHF + , hfoAccumulator = HF.hfAccumulator newHF + } + +hfSignature :: [Sig] +hfSignature = + [ monoTypeObserve (Proxy :: Proxy (HFIns Int String)) + , con "new" (HF.new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) + , con "insert" (HF.insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) + , con "view" (HF.view :: HistoricalFold Int String -> Int) + , con "historyLength" (HF.historyLength :: HistoricalFold Int String -> Int) + , con "rewind" (HF.rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) + , withMaxTermSize 4 + ] diff --git a/test/Model.hs b/test/Model.hs deleted file mode 100644 index 6204ec0578..0000000000 --- a/test/Model.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Model ( -- * Model data - HistoricalFold - -- Should we provide access to these? - , hfDepth - , hfAccumulator - , hfFunction - -- * Model functionality - , new - , insert - , view - , historyLength - , rewind - , matchesHistory - -- * Helpers - , insertL - -- * QuickSpec - , hfSignature - ) where - -import Control.Monad (replicateM) -import Data.List (foldl', isInfixOf) -import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) -import qualified Data.List.NonEmpty as NE -import Data.Map (Map) -import Data.Maybe (fromJust) -import GHC.Generics - -import QuickSpec -import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, - choose, chooseInt, frequency, listOf, - sized) - -import qualified Debug.Trace as Debug - --- | Model of a historical (we can go backwards) fold over a data set. - --- Should we make `b` a monoid? -data HistoricalFold a b = HistoricalFold - { hfFunction :: a -> b -> a - , hfDepth :: Int - , hfAccumulator :: NonEmpty a - } deriving (Typeable) - -instance (Show a, Show b) => Show (HistoricalFold a b) where - show (HistoricalFold _ depth acc) = - show $ "HistoricalFold { hfDepth = " <> show depth <> ", hfAccumulator = " <> show (toList acc) <> " }" - --- | Operations over the historical folds. -new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) -new fn depth acc - | depth <= 0 = Nothing - | otherwise = Just $ - HistoricalFold { hfFunction = fn - , hfDepth = depth - , hfAccumulator = acc :| [] - } - -insert :: b -> HistoricalFold a b -> HistoricalFold a b -insert v hf@(HistoricalFold fn depth acc@(hacc :| _)) = - -- forall hf v. historyLength (insert v hf) > 0 - -- Take will always return something non-null. - hf { hfAccumulator = NE.fromList $ NE.take depth $ - fn hacc v <| acc } - -insertL :: [b] -> HistoricalFold a b -> HistoricalFold a b -insertL bs hf = foldl' (flip insert) hf bs - -view :: HistoricalFold a b -> a -view (HistoricalFold _ _ (hacc :| _)) = hacc - -historyLength :: HistoricalFold a b -> Int -historyLength (HistoricalFold _ _ acc) = NE.length acc - -rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) -rewind depth hf - | hfDepth hf <= depth = Nothing - | historyLength hf < depth = Nothing - | otherwise = Just $ hf { hfAccumulator = NE.fromList - $ NE.drop depth (hfAccumulator hf) } - -matchesHistory :: (Show a, Eq a) => HistoricalFold a b -> HistoricalFold a b -> Bool -matchesHistory hl hr = - let hlAccumulator = toList $ hfAccumulator hl - hrAccumulator = toList $ hfAccumulator hr - in hlAccumulator `isInfixOf` hrAccumulator - || hrAccumulator `isInfixOf` hlAccumulator - || hrAccumulator == hlAccumulator - --- QuickCheck infrastructure -instance ( CoArbitrary a - , CoArbitrary b - , Arbitrary a - , Arbitrary b ) => Arbitrary (HistoricalFold a b) where - arbitrary = sized $ \n -> do - -- What happens when n is 0 or 1? - depth <- frequency [ (05, pure 1) - , (40, chooseInt (2, n + 2)) - , (40, chooseInt (n + 2, n * 2 + 2)) - ] - overflow <- chooseInt (depth, depth * 2) - acc <- arbitrary - fn <- arbitrary - bs <- frequency [ (05, pure []) -- empty - , (50, arbitrary) -- randomized - , (30, replicateM (depth `div` 2) -- half filled - arbitrary) - , (10, replicateM overflow arbitrary) -- overfilled - , (05, replicateM depth arbitrary) -- exact - ] - -- Construction can only fail due to NonPositive depth - -- Tested with prop_hfNewReturns... - let newHf = fromJust $ new fn depth acc - pure $ insertL bs newHf - --- QuickSpec infrastructure -data HFObs a = HFObs - { hfoDepth :: Int - , hfoAccumulator :: NonEmpty a - } deriving (Eq, Ord, Typeable) - -newtype HFIns a b = HFIns [b] - deriving (Eq, Ord, Typeable) - -instance Arbitrary b => Arbitrary (HFIns a b) where - arbitrary = HFIns <$> listOf arbitrary - -instance ( Ord a - , Arbitrary a - , Arbitrary b - , CoArbitrary a - , CoArbitrary b ) => Observe (HistoricalFold a b) (HFObs a) (HFIns a b) where - observe hf (HFIns bs) = - let newHF = insertL bs hf - in HFObs { hfoDepth = hfDepth newHF - , hfoAccumulator = hfAccumulator newHF - } - -hfSignature :: [Sig] -hfSignature = - [ monoTypeObserve (Proxy :: Proxy (HFIns Int String)) - , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) - , con "insert" (insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) - , con "view" (view :: HistoricalFold Int String -> Int) - , con "historyLength" (historyLength :: HistoricalFold Int String -> Int) - , con "rewind" (rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) - , withMaxTermSize 4 - ] diff --git a/test/Spec.hs b/test/Spec.hs index aae285161a..18b2f7557a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,13 +1,12 @@ +import QuickSpec import Test.Tasty import Test.Tasty.QuickCheck -import QuickSpec import Data.List (foldl') import Data.Maybe (fromJust, isJust, isNothing) -import Model - -import qualified Debug.Trace as Debug +import Index.HistoricalFold +import HistoricalFold tests :: TestTree tests = testGroup "Utxo index" [hfProperties] From a7ff132a1928a1a7c24bde42a3992ccbd4176d1d Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 17 Feb 2022 21:58:55 +0200 Subject: [PATCH 18/62] Make new not run in a monad. --- src/Index/Stored.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Index/Stored.hs b/src/Index/Stored.hs index 1c39487b85..9ccf10ecc0 100644 --- a/src/Index/Stored.hs +++ b/src/Index/Stored.hs @@ -23,11 +23,11 @@ data StoredIndex m a e = StoredIndex storeEventsThreshold :: Int storeEventsThreshold = 3 -new :: Monad m => (a -> [e] -> m a) -> Int -> a -> m (Maybe (StoredIndex m a e)) +new :: Monad m => (a -> [e] -> m a) -> Int -> m a -> Maybe (StoredIndex m a e) new store depth acc - | depth <= 0 = pure Nothing - | otherwise = pure $ Just $ StoredIndex - { siHandle = pure acc + | depth <= 0 = Nothing + | otherwise = Just $ StoredIndex + { siHandle = acc , siEvents = [] , siDepth = depth , siStore = store From 17dc6ad89fda1ac3148596376694b67c313408bb Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 17 Feb 2022 22:27:23 +0200 Subject: [PATCH 19/62] Fix the Observable definition for quickspec. --- test/HistoricalFold.hs | 6 +++--- test/Spec.hs | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/test/HistoricalFold.hs b/test/HistoricalFold.hs index 7db589bd16..8d926a5f98 100644 --- a/test/HistoricalFold.hs +++ b/test/HistoricalFold.hs @@ -63,8 +63,8 @@ instance ( Ord a , Arbitrary a , Arbitrary b , CoArbitrary a - , CoArbitrary b ) => Observe (HistoricalFold a b) (HFObs a) (HFIns a b) where - observe hf (HFIns bs) = + , CoArbitrary b ) => Observe (HFIns a b) (HFObs a) (HistoricalFold a b) where + observe (HFIns bs) hf = let newHF = HF.insertL bs hf in HFObs { hfoDepth = HF.hfDepth newHF , hfoAccumulator = HF.hfAccumulator newHF @@ -72,7 +72,7 @@ instance ( Ord a hfSignature :: [Sig] hfSignature = - [ monoTypeObserve (Proxy :: Proxy (HFIns Int String)) + [ monoObserve @(HistoricalFold Int String) , con "new" (HF.new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) , con "insert" (HF.insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) , con "view" (HF.view :: HistoricalFold Int String -> Int) diff --git a/test/Spec.hs b/test/Spec.hs index 18b2f7557a..7cb02988d8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -114,5 +114,6 @@ prop_InsertHistoryLength hf b = else finalLength === initialLength + 1 main :: IO () -main = +main = do + quickSpec hfSignature defaultMain tests From 71b8325713965f8b7d5960c569fb1319cdc2cc85 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 17 Feb 2022 23:22:37 +0200 Subject: [PATCH 20/62] More quickspec bug fixes. --- test/HistoricalFold.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/test/HistoricalFold.hs b/test/HistoricalFold.hs index 8d926a5f98..25dd41e9cb 100644 --- a/test/HistoricalFold.hs +++ b/test/HistoricalFold.hs @@ -12,7 +12,7 @@ import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) import GHC.Generics import QuickSpec -import Test.QuickCheck (Arbitrary (arbitrary), CoArbitrary, Gen, +import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Gen, choose, chooseInt, frequency, listOf, sized) @@ -73,10 +73,15 @@ instance ( Ord a hfSignature :: [Sig] hfSignature = [ monoObserve @(HistoricalFold Int String) + , monoObserve @(HistoricalFold Int Int) + , monoObserve @(HistoricalFold Int [Int]) + , monoObserve @(Maybe (HistoricalFold Int String)) + , monoObserve @(Maybe (HistoricalFold Int Int)) + , monoObserve @(Maybe (HistoricalFold Int [Int])) , con "new" (HF.new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) , con "insert" (HF.insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) , con "view" (HF.view :: HistoricalFold Int String -> Int) , con "historyLength" (HF.historyLength :: HistoricalFold Int String -> Int) , con "rewind" (HF.rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) - , withMaxTermSize 4 + , withMaxTermSize 6 ] From 804c6cfbed095217b1a634fb1fc5fad107cebbb0 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 22 Feb 2022 22:30:42 +0200 Subject: [PATCH 21/62] Simplify base model. Write the simiplified model as an initial algebra and define some of the instances previously defined for `HistoricalFold`. --- hysterical-screams.cabal | 11 ++- package.yaml | 5 ++ src/Index.hs | 155 +++++++++++++++++++++++++++++++++++++++ stack.yaml | 2 +- stack.yaml.lock | 8 +- test/HistoricalFold.hs | 25 +++---- 6 files changed, 186 insertions(+), 20 deletions(-) create mode 100644 src/Index.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 5089560cb2..608d8ee618 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -28,6 +28,7 @@ source-repository head library exposed-modules: + Index Index.HistoricalFold Index.Stored other-modules: @@ -40,8 +41,13 @@ library TypeApplications PatternSynonyms DeriveGeneric + MultiParamTypeClasses + FlexibleInstances + GADTs build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 + , quickspec default-language: Haskell2010 test-suite hysterical-screams-test @@ -58,6 +64,9 @@ test-suite hysterical-screams-test TypeApplications PatternSynonyms DeriveGeneric + MultiParamTypeClasses + FlexibleInstances + GADTs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck diff --git a/package.yaml b/package.yaml index cb4495348e..b93eddc3d8 100644 --- a/package.yaml +++ b/package.yaml @@ -27,9 +27,14 @@ default-extensions: - TypeApplications - PatternSynonyms - DeriveGeneric + - MultiParamTypeClasses + - FlexibleInstances + - GADTs dependencies: - base >= 4.7 && < 5 +- QuickCheck +- quickspec library: source-dirs: src diff --git a/src/Index.hs b/src/Index.hs new file mode 100644 index 0000000000..5fe10312e1 --- /dev/null +++ b/src/Index.hs @@ -0,0 +1,155 @@ +module Index + ( Index + -- * Constructors + , new + , insert + , rewind + -- * Projections + , IndexView(..) + , view + -- * Helpers + , insertL + ) where + +import Control.Monad (replicateM) +import Data.Foldable (foldl') +import Data.Maybe (fromJust) +import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, + arbitrarySizedIntegral, choose, chooseInt, + frequency, listOf, sized) +import QuickSpec + +data Index a b where + New :: (a -> b -> a) -> Int -> a -> Index a b + Insert :: b -> Index a b -> Index a b + Rewind :: Int -> Index a b -> Index a b + +newtype GrammarIndex a b = GrammarIndex (Index a b) + +newtype ObservedIndex a b = ObservedIndex (Index a b) + +data IndexView a = IndexView + { ixDepth :: Int + , ixView :: a + , ixSize :: Int + } deriving (Show, Ord, Eq) + +-- | Constructors + +new :: (a -> b -> a) -> Int -> a -> Maybe (Index a b) +new f depth initial + | depth > 0 = Just $ New f depth initial + | otherwise = Nothing + +insert :: b -> Index a b -> Index a b +insert = Insert + +insertL bs ix = foldl' (flip insert) ix bs + +rewind :: Int -> Index a b -> Maybe (Index a b) +rewind n ix + | ixDepth (view ix) <= n = Nothing + | ixSize (view ix) < n = Nothing + | otherwise = Just $ Rewind n ix + +-- | Observations + +view :: Index a b -> IndexView a +view (New f depth initial) = + IndexView { ixDepth = depth + , ixView = initial + , ixSize = 0 + } +view (Insert b ix) = + let f = getFunction ix + v = view ix + in v { ixView = f (ixView v) b + , ixSize = ixSize v + 1 + } +view (Rewind n ix) = + let h = getHistory ix + v = view ix + in v { ixSize = ixSize v - n + , ixView = head $ drop n h + } + +-- | Internal + +getFunction :: Index a b -> (a -> b -> a) +getFunction (New f _ _) = f +getFunction (Insert _ ix) = getFunction ix +getFunction (Rewind _ ix) = getFunction ix + +getHistory :: Index a b -> [a] +getHistory (New _ _ i) = [i] +getHistory (Insert b ix) = + let f = getFunction ix + h = getHistory ix + in f (head h) b : h +getHistory (Rewind n ix) = drop n $ getHistory ix + +-- | QuickCheck + +instance ( CoArbitrary a + , CoArbitrary b + , Arbitrary a + , Arbitrary b ) => Arbitrary (ObservedIndex a b) where + arbitrary = sized $ \n -> do + depth <- frequency [ (05, pure 1) -- overfill + , (40, chooseInt (2, n + 2)) -- about filled + , (40, chooseInt (n + 2, n * 2 + 2)) -- not filled + ] + overflow <- chooseInt (depth, depth * 2) + acc <- arbitrary + fn <- arbitrary + bs <- frequency [ (05, pure []) -- empty + , (50, arbitrary) -- randomized + , (30, replicateM (depth `div` 2) -- half filled + arbitrary) + , (10, replicateM overflow arbitrary) -- overfilled + , (05, replicateM depth arbitrary) -- exact + ] + -- Construction can only fail due to NonPositive depth + -- Tested with prop_hfNewReturns... + let newHf = fromJust $ new fn depth acc + pure . ObservedIndex $ insertL bs newHf + +instance ( CoArbitrary a + , CoArbitrary b + , Arbitrary a + , Arbitrary b ) => Arbitrary (GrammarIndex a b) where + arbitrary = sized $ \n -> do + depth <- frequency [ (05, pure 1) -- overfill + , (40, chooseInt (2, n + 2)) -- about filled + , (40, chooseInt (n + 2, n * 2 + 2)) -- not filled + ] + f <- arbitrary + acc <- arbitrary + let ix = fromJust $ new f depth acc + complexity <- arbitrarySizedIntegral + generateGrammarIndex complexity ix + +generateGrammarIndex :: Arbitrary b => Int -> Index a b -> Gen (GrammarIndex a b) +generateGrammarIndex 0 ix = pure $ GrammarIndex ix +generateGrammarIndex n ix = do + b <- arbitrary + n <- chooseInt (1, ixDepth $ view ix) + nextIx <- frequency [ (80, pure $ insert b ix) + , (20, pure . fromJust $ rewind n ix) + ] + generateGrammarIndex (n - 1) nextIx + +-- | QuickSpec + +newtype IxEvents b = IxEvents [b] + deriving (Eq, Ord, Typeable) + +instance Arbitrary b => Arbitrary (IxEvents b) where + arbitrary = IxEvents <$> listOf arbitrary + +instance ( Ord a + , Arbitrary a + , Arbitrary b + , CoArbitrary a + , CoArbitrary b) => Observe (IxEvents b) (IndexView a) (Index a b) where + observe (IxEvents es) ix = view $ insertL es ix diff --git a/stack.yaml b/stack.yaml index 46d9939013..2562271b2d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 4e4a06c2f8..dc1a879cf4 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -20,8 +20,8 @@ packages: hackage: twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 snapshots: - completed: - sha256: f9970d6f25c63e3e4265aa8e9c69a047ba8919d1107e4996bdd7555b75aad0eb - size: 586120 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml + sha256: 1b74fb5e970497b5aefae56703f1bd44aa648bd1a5ef95c1eb8c29775087e2bf + size: 587393 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml diff --git a/test/HistoricalFold.hs b/test/HistoricalFold.hs index 25dd41e9cb..3c44fa068f 100644 --- a/test/HistoricalFold.hs +++ b/test/HistoricalFold.hs @@ -1,25 +1,22 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - module HistoricalFold ( hfSignature ) where -import Control.Monad (replicateM) -import Data.Map (Map) -import Data.Maybe (fromJust) -import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) +import Control.Monad (replicateM) +import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) +import Data.Map (Map) +import Data.Maybe (fromJust) import GHC.Generics import QuickSpec -import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Gen, - choose, chooseInt, frequency, listOf, - sized) +import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, + choose, chooseInt, frequency, listOf, + sized) -import Index.HistoricalFold (HistoricalFold) -import Index.HistoricalFold qualified as HF +import Index.HistoricalFold (HistoricalFold) +import qualified Index.HistoricalFold as HF -import qualified Debug.Trace as Debug +import qualified Debug.Trace as Debug -- QuickCheck infrastructure instance ( CoArbitrary a @@ -83,5 +80,5 @@ hfSignature = , con "view" (HF.view :: HistoricalFold Int String -> Int) , con "historyLength" (HF.historyLength :: HistoricalFold Int String -> Int) , con "rewind" (HF.rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) - , withMaxTermSize 6 + , withMaxTermSize 5 ] From d43ad366007aea026b0ea1c3fc0132f266f8e40a Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 22 Feb 2022 23:26:30 +0200 Subject: [PATCH 22/62] Switch tests to the new model. --- src/Index.hs | 37 +++++++++++++++++++----- test/Spec.hs | 79 ++++++++++++++++++++++++++++------------------------ 2 files changed, 72 insertions(+), 44 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 5fe10312e1..d41ff87e31 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -7,26 +7,39 @@ module Index -- * Projections , IndexView(..) , view + , getFunction + , getHistory -- * Helpers , insertL + , matches + -- * Testing + , ObservedIndex (..) + , GrammarIndex (..) ) where import Control.Monad (replicateM) import Data.Foldable (foldl') +import Data.List (isInfixOf) import Data.Maybe (fromJust) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, arbitrarySizedIntegral, choose, chooseInt, frequency, listOf, sized) import QuickSpec -data Index a b where - New :: (a -> b -> a) -> Int -> a -> Index a b - Insert :: b -> Index a b -> Index a b - Rewind :: Int -> Index a b -> Index a b +data Index a b = New (a -> b -> a) Int a + | Insert b (Index a b) + | Rewind Int (Index a b) + +instance (Show a, Show b) => Show (Index a b) where + show (New f depth acc) = "New " <> show depth <> " " <> show acc + show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" + show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" newtype GrammarIndex a b = GrammarIndex (Index a b) + deriving (Show) newtype ObservedIndex a b = ObservedIndex (Index a b) + deriving (Show) data IndexView a = IndexView { ixDepth :: Int @@ -44,8 +57,6 @@ new f depth initial insert :: b -> Index a b -> Index a b insert = Insert -insertL bs ix = foldl' (flip insert) ix bs - rewind :: Int -> Index a b -> Maybe (Index a b) rewind n ix | ixDepth (view ix) <= n = Nothing @@ -64,7 +75,7 @@ view (Insert b ix) = let f = getFunction ix v = view ix in v { ixView = f (ixView v) b - , ixSize = ixSize v + 1 + , ixSize = min (ixDepth v) (ixSize v + 1) } view (Rewind n ix) = let h = getHistory ix @@ -88,6 +99,18 @@ getHistory (Insert b ix) = in f (head h) b : h getHistory (Rewind n ix) = drop n $ getHistory ix +-- | Utility + +matches :: Eq a => Index a b -> Index a b -> Bool +matches hl hr = + let hlAccumulator = getHistory hl + hrAccumulator = getHistory hr + in hlAccumulator `isInfixOf` hrAccumulator + || hrAccumulator `isInfixOf` hlAccumulator + || hrAccumulator == hlAccumulator + +insertL :: [b] -> Index a b -> Index a b +insertL bs ix = foldl' (flip insert) ix bs -- | QuickCheck instance ( CoArbitrary a diff --git a/test/Spec.hs b/test/Spec.hs index 7cb02988d8..19955e9e5e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,14 +5,14 @@ import Test.Tasty.QuickCheck import Data.List (foldl') import Data.Maybe (fromJust, isJust, isNothing) -import Index.HistoricalFold +import Index import HistoricalFold tests :: TestTree -tests = testGroup "Utxo index" [hfProperties] +tests = testGroup "Index" [hfProperties] hfProperties :: TestTree -hfProperties = testGroup "Historical fold" +hfProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ prop_hfNewReturn @Int @Int , testProperty "History length is always smaller than the max depth" $ @@ -47,73 +47,78 @@ prop_hfNewReturn f acc = -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (hfDepth hf == 1) prop_rewindWithDepth - :: HistoricalFold a b + :: ObservedIndex a b -> Property -prop_rewindWithDepth hf = - hfDepth hf >= 2 ==> - forAll (frequency [ (20, chooseInt (hfDepth hf, hfDepth hf * 2)) - , (30, chooseInt (historyLength hf + 1, hfDepth hf - 1)) - , (50, chooseInt (1, historyLength hf)) ]) $ +prop_rewindWithDepth (ObservedIndex ix) = + let v = view ix in + ixDepth v >= 2 ==> + forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) + , (30, chooseInt (ixSize v + 1, ixDepth v - 1)) + , (50, chooseInt (1, ixSize v)) ]) $ \depth -> - cover 15 (depth > hfDepth hf) "Depth is larger than max depth." $ - cover 15 (depth <= hfDepth hf && depth > historyLength hf) + cover 15 (depth > ixDepth v) "Depth is larger than max depth." $ + cover 15 (depth <= ixDepth v && depth > ixSize v) "Depth is lower than max but there is not enough data." $ - cover 40 (depth <= hfDepth hf && depth <= historyLength hf) + cover 40 (depth <= ixDepth v && depth <= ixSize v) "Depth is properly set." $ - let newHF = rewind depth hf - in if depth > (hfDepth hf - 1) || (depth > historyLength hf) - then property $ isNothing newHF - else property $ isJust newHF + let newIx = rewind depth ix + in if depth > (ixDepth v - 1) || (depth > ixSize v) + then property $ isNothing newIx + else property $ isJust newIx -- | Property that validates the HF data structure. prop_historyLengthLEDepth - :: HistoricalFold a b + :: ObservedIndex a b -> Property -prop_historyLengthLEDepth hf = - property $ historyLength hf <= hfDepth hf +prop_historyLengthLEDepth (ObservedIndex ix) = + let v = view ix + in property $ ixSize v <= ixDepth v -- | Relation between Rewind and Inverse prop_InsertRewindInverse :: (Show a, Show b, Arbitrary b, Eq a) - => HistoricalFold a b + => ObservedIndex a b -> Property -prop_InsertRewindInverse hf = +prop_InsertRewindInverse (ObservedIndex ix) = + let v = view ix -- rewind does not make sense for lesser depths. - hfDepth hf >= 2 ==> + in ixDepth v >= 2 ==> -- if the history is not fully re-written, then we can get a common -- prefix after the insert/rewind play. We need input which is less -- than `hfDepth hf` - forAll (resize (hfDepth hf - 1) arbitrary) $ + forAll (resize (ixDepth v - 1) arbitrary) $ \bs -> - let hf' = rewind (length bs) $ insertL bs hf - in property $ isJust hf' && fromJust hf' `matchesHistory` hf + let ix' = rewind (length bs) $ insertL bs ix + v' = view (fromJust ix') + in property $ isJust ix' && fromJust ix' `matches` ix -- | Generally this would not be a good property since it is very coupled -- to the implementation, but it will be useful when trying to certify that -- another implmentation is confirming. prop_InsertFolds :: (Eq a, Show a) - => HistoricalFold a b + => ObservedIndex a b -> [b] -> Property -prop_InsertFolds hf bs = - view (insertL bs hf) === - foldl' (hfFunction hf) (view hf) bs +prop_InsertFolds (ObservedIndex ix) bs = + ixView (view (insertL bs ix)) === + foldl' (getFunction ix) (ixView $ view ix) bs prop_InsertHistoryLength - :: HistoricalFold a b + :: ObservedIndex a b -> b -> Property -prop_InsertHistoryLength hf b = - let initialLength = historyLength hf - finalLength = historyLength (insert b hf) - in cover 10 (initialLength == hfDepth hf) "Overflowing" $ - cover 30 (initialLength < hfDepth hf) "Not filled" $ - if initialLength == hfDepth hf +prop_InsertHistoryLength (ObservedIndex ix) b = + let v = view ix + initialLength = ixSize v + finalLength = ixSize . view $ insert b ix + in cover 10 (initialLength == ixDepth v) "Overflowing" $ + cover 30 (initialLength < ixDepth v) "Not filled" $ + if initialLength == ixDepth v then finalLength === initialLength else finalLength === initialLength + 1 main :: IO () main = do - quickSpec hfSignature + -- quickSpec hfSignature defaultMain tests From adccb8620d659f8e68e038db63e55202cd49f038 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 22 Feb 2022 23:58:28 +0200 Subject: [PATCH 23/62] Switch quickspec to use the new model. --- src/Index.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++-- test/Spec.hs | 3 +-- 2 files changed, 45 insertions(+), 4 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index d41ff87e31..1e75a93f98 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} + module Index ( Index -- * Constructors @@ -15,6 +18,7 @@ module Index -- * Testing , ObservedIndex (..) , GrammarIndex (..) + , ixSignature ) where import Control.Monad (replicateM) @@ -25,6 +29,7 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, arbitrarySizedIntegral, choose, chooseInt, frequency, listOf, sized) import QuickSpec +import GHC.Generics data Index a b = New (a -> b -> a) Int a | Insert b (Index a b) @@ -45,7 +50,7 @@ data IndexView a = IndexView { ixDepth :: Int , ixView :: a , ixSize :: Int - } deriving (Show, Ord, Eq) + } deriving (Show, Ord, Eq, Typeable, Generic) -- | Constructors @@ -96,7 +101,8 @@ getHistory (New _ _ i) = [i] getHistory (Insert b ix) = let f = getFunction ix h = getHistory ix - in f (head h) b : h + v = view ix + in f (head h) b : take (ixDepth v - 1) h getHistory (Rewind n ix) = drop n $ getHistory ix -- | Utility @@ -137,6 +143,15 @@ instance ( CoArbitrary a let newHf = fromJust $ new fn depth acc pure . ObservedIndex $ insertL bs newHf +instance ( CoArbitrary a + , CoArbitrary b + , Arbitrary a + , Arbitrary b ) => Arbitrary (Index a b) where + -- Use the ObservedIndex instance as a generator for Indexes + arbitrary = do + (ObservedIndex ix) <- arbitrary + pure ix + instance ( CoArbitrary a , CoArbitrary b , Arbitrary a @@ -162,6 +177,16 @@ generateGrammarIndex n ix = do ] generateGrammarIndex (n - 1) nextIx +instance Arbitrary a => Arbitrary (IndexView a) where + arbitrary = sized $ \n -> do + depth <- chooseInt (2, n) + size <- chooseInt (0, depth) + view <- arbitrary + pure IndexView { ixDepth = depth + , ixSize = size + , ixView = view + } + -- | QuickSpec newtype IxEvents b = IxEvents [b] @@ -176,3 +201,20 @@ instance ( Ord a , CoArbitrary a , CoArbitrary b) => Observe (IxEvents b) (IndexView a) (Index a b) where observe (IxEvents es) ix = view $ insertL es ix + +ixSignature :: [Sig] +ixSignature = + [ monoObserve @(Index Int String) + , monoObserve @(Index Int Int) + , monoObserve @(Index Int [Int]) + , mono @(IndexView Int) + , monoObserve @(Maybe (Index Int String)) + , monoObserve @(Maybe (Index Int Int)) + , monoObserve @(Maybe (Index Int [Int])) + , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Maybe (Index Int String)) + , con "insert" (insert :: String -> Index Int String -> Index Int String) + , con "view" (view :: Index Int String -> IndexView Int) + , con "rewind" (rewind :: Int -> Index Int String -> Maybe (Index Int String)) + , con "getHistory" (getHistory :: Index Int String -> [Int]) + , withMaxTermSize 6 + ] diff --git a/test/Spec.hs b/test/Spec.hs index 19955e9e5e..927690599c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,7 +6,6 @@ import Data.List (foldl') import Data.Maybe (fromJust, isJust, isNothing) import Index -import HistoricalFold tests :: TestTree tests = testGroup "Index" [hfProperties] @@ -120,5 +119,5 @@ prop_InsertHistoryLength (ObservedIndex ix) b = main :: IO () main = do - -- quickSpec hfSignature + quickSpec ixSignature defaultMain tests From 70752328b2fa445767e9b4b1ad1ddb17f10d29c5 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 22 Feb 2022 23:59:44 +0200 Subject: [PATCH 24/62] Remove `HistoricalFold`. --- hysterical-screams.cabal | 2 - src/Index/HistoricalFold.hs | 78 ---------------------------------- test/HistoricalFold.hs | 84 ------------------------------------- test/Spec.hs | 2 +- 4 files changed, 1 insertion(+), 165 deletions(-) delete mode 100644 src/Index/HistoricalFold.hs delete mode 100644 test/HistoricalFold.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 608d8ee618..972c5df8a2 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -29,7 +29,6 @@ source-repository head library exposed-modules: Index - Index.HistoricalFold Index.Stored other-modules: Paths_hysterical_screams @@ -54,7 +53,6 @@ test-suite hysterical-screams-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - HistoricalFold Paths_hysterical_screams hs-source-dirs: test diff --git a/src/Index/HistoricalFold.hs b/src/Index/HistoricalFold.hs deleted file mode 100644 index c7cba05a85..0000000000 --- a/src/Index/HistoricalFold.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Index.HistoricalFold - ( HistoricalFold - -- * Accessors - , hfDepth - , hfAccumulator - , hfFunction - -- * Functions - , new - , insert - , view - , historyLength - , rewind - , matchesHistory - -- * Helpers - , insertL - ) where - -import Data.List (foldl', isInfixOf) -import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) -import qualified Data.List.NonEmpty as NE -import Data.Typeable (Typeable) -import GHC.Generics - --- | Model of a historical (we can go backwards) fold over a data set. - --- Should we make `b` a monoid? -data HistoricalFold a b = HistoricalFold - { hfFunction :: a -> b -> a - , hfDepth :: Int - , hfAccumulator :: NonEmpty a - } deriving (Typeable) - -instance (Show a, Show b) => Show (HistoricalFold a b) where - show (HistoricalFold _ depth acc) = - show $ "HistoricalFold { hfDepth = " <> show depth <> ", hfAccumulator = " <> show (toList acc) <> " }" - --- | Operations over the historical folds. -new :: (a -> b -> a) -> Int -> a -> Maybe (HistoricalFold a b) -new fn depth acc - | depth <= 0 = Nothing - | otherwise = Just $ - HistoricalFold { hfFunction = fn - , hfDepth = depth - , hfAccumulator = acc :| [] - } - -insert :: b -> HistoricalFold a b -> HistoricalFold a b -insert v hf@(HistoricalFold fn depth acc@(hacc :| _)) = - -- forall hf v. historyLength (insert v hf) > 0 - -- Take will always return something non-null. - hf { hfAccumulator = NE.fromList $ NE.take depth $ - fn hacc v <| acc } - -insertL :: [b] -> HistoricalFold a b -> HistoricalFold a b -insertL bs hf = foldl' (flip insert) hf bs - -view :: HistoricalFold a b -> a -view (HistoricalFold _ _ (hacc :| _)) = hacc - -historyLength :: HistoricalFold a b -> Int -historyLength (HistoricalFold _ _ acc) = NE.length acc - -rewind :: Int -> HistoricalFold a b -> Maybe (HistoricalFold a b) -rewind depth hf - | hfDepth hf <= depth = Nothing - | historyLength hf < depth = Nothing - | otherwise = Just $ hf { hfAccumulator = NE.fromList - $ NE.drop depth (hfAccumulator hf) } - -matchesHistory :: (Show a, Eq a) => HistoricalFold a b -> HistoricalFold a b -> Bool -matchesHistory hl hr = - let hlAccumulator = toList $ hfAccumulator hl - hrAccumulator = toList $ hfAccumulator hr - in hlAccumulator `isInfixOf` hrAccumulator - || hrAccumulator `isInfixOf` hlAccumulator - || hrAccumulator == hlAccumulator - - diff --git a/test/HistoricalFold.hs b/test/HistoricalFold.hs deleted file mode 100644 index 3c44fa068f..0000000000 --- a/test/HistoricalFold.hs +++ /dev/null @@ -1,84 +0,0 @@ -module HistoricalFold - ( hfSignature - ) where - -import Control.Monad (replicateM) -import Data.List.NonEmpty (NonEmpty (..), toList, (<|)) -import Data.Map (Map) -import Data.Maybe (fromJust) -import GHC.Generics - -import QuickSpec -import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, - choose, chooseInt, frequency, listOf, - sized) - -import Index.HistoricalFold (HistoricalFold) -import qualified Index.HistoricalFold as HF - -import qualified Debug.Trace as Debug - --- QuickCheck infrastructure -instance ( CoArbitrary a - , CoArbitrary b - , Arbitrary a - , Arbitrary b ) => Arbitrary (HistoricalFold a b) where - arbitrary = sized $ \n -> do - -- What happens when n is 0 or 1? - depth <- frequency [ (05, pure 1) - , (40, chooseInt (2, n + 2)) - , (40, chooseInt (n + 2, n * 2 + 2)) - ] - overflow <- chooseInt (depth, depth * 2) - acc <- arbitrary - fn <- arbitrary - bs <- frequency [ (05, pure []) -- empty - , (50, arbitrary) -- randomized - , (30, replicateM (depth `div` 2) -- half filled - arbitrary) - , (10, replicateM overflow arbitrary) -- overfilled - , (05, replicateM depth arbitrary) -- exact - ] - -- Construction can only fail due to NonPositive depth - -- Tested with prop_hfNewReturns... - let newHf = fromJust $ HF.new fn depth acc - pure $ HF.insertL bs newHf - --- QuickSpec infrastructure -data HFObs a = HFObs - { hfoDepth :: Int - , hfoAccumulator :: NonEmpty a - } deriving (Eq, Ord, Typeable) - -newtype HFIns a b = HFIns [b] - deriving (Eq, Ord, Typeable) - -instance Arbitrary b => Arbitrary (HFIns a b) where - arbitrary = HFIns <$> listOf arbitrary - -instance ( Ord a - , Arbitrary a - , Arbitrary b - , CoArbitrary a - , CoArbitrary b ) => Observe (HFIns a b) (HFObs a) (HistoricalFold a b) where - observe (HFIns bs) hf = - let newHF = HF.insertL bs hf - in HFObs { hfoDepth = HF.hfDepth newHF - , hfoAccumulator = HF.hfAccumulator newHF - } - -hfSignature :: [Sig] -hfSignature = - [ monoObserve @(HistoricalFold Int String) - , monoObserve @(HistoricalFold Int Int) - , monoObserve @(HistoricalFold Int [Int]) - , monoObserve @(Maybe (HistoricalFold Int String)) - , monoObserve @(Maybe (HistoricalFold Int Int)) - , monoObserve @(Maybe (HistoricalFold Int [Int])) - , con "new" (HF.new :: (Int -> String -> Int) -> Int -> Int -> Maybe (HistoricalFold Int String)) - , con "insert" (HF.insert :: String -> HistoricalFold Int String -> HistoricalFold Int String) - , con "view" (HF.view :: HistoricalFold Int String -> Int) - , con "historyLength" (HF.historyLength :: HistoricalFold Int String -> Int) - , con "rewind" (HF.rewind :: Int -> HistoricalFold Int String -> Maybe (HistoricalFold Int String)) - , withMaxTermSize 5 - ] diff --git a/test/Spec.hs b/test/Spec.hs index 927690599c..e5b7f2de97 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -119,5 +119,5 @@ prop_InsertHistoryLength (ObservedIndex ix) b = main :: IO () main = do - quickSpec ixSignature + -- quickSpec ixSignature defaultMain tests From bc05944df565053d8333a2456b4c2e83ba405503 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 23 Feb 2022 10:37:11 +0200 Subject: [PATCH 25/62] Rename Stored to Split and refactor. Figure out how the view would look like for a split index. --- hysterical-screams.cabal | 2 +- src/Index.hs | 2 +- src/Index/Split.hs | 76 ++++++++++++++++++++++++++++++++++++++++ src/Index/Stored.hs | 65 ---------------------------------- 4 files changed, 78 insertions(+), 67 deletions(-) create mode 100644 src/Index/Split.hs delete mode 100644 src/Index/Stored.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 972c5df8a2..40e88222d7 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -29,7 +29,7 @@ source-repository head library exposed-modules: Index - Index.Stored + Index.Split other-modules: Paths_hysterical_screams hs-source-dirs: diff --git a/src/Index.hs b/src/Index.hs index 1e75a93f98..d1fd518204 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -207,10 +207,10 @@ ixSignature = [ monoObserve @(Index Int String) , monoObserve @(Index Int Int) , monoObserve @(Index Int [Int]) - , mono @(IndexView Int) , monoObserve @(Maybe (Index Int String)) , monoObserve @(Maybe (Index Int Int)) , monoObserve @(Maybe (Index Int [Int])) + , mono @(IndexView Int) , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Maybe (Index Int String)) , con "insert" (insert :: String -> Index Int String -> Index Int String) , con "view" (view :: Index Int String -> IndexView Int) diff --git a/src/Index/Split.hs b/src/Index/Split.hs new file mode 100644 index 0000000000..cb39da6951 --- /dev/null +++ b/src/Index/Split.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +module Index.Split + ( SplitIndex + , new + , insert + , insertL + , view + , historyLength + , rewind + ) where + +import Data.Foldable (foldlM) + +data SplitIndex m a e = SplitIndex + { siHandle :: m a + , siEvents :: [e] + , siDepth :: Int + , siStore :: a -> [e] -> m a + , siView :: forall b. (SplitIndex m a e -> m b) -> SplitIndex m a e -> m b + } + +type SplitIndexView m a e = + forall b. (SplitIndex m a e -> m b) -> SplitIndex m a e -> m b + +storeEventsThreshold :: Int +storeEventsThreshold = 3 + +new + :: Monad m + => SplitIndexView m a e + -> (a -> [e] -> m a) + -> Int + -> m a + -> Maybe (SplitIndex m a e) +new view store depth acc + | depth <= 0 = Nothing + | otherwise = Just $ SplitIndex + { siHandle = acc + , siEvents = [] + , siDepth = depth + , siStore = store + , siView = view + } + +insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) +insert e ix@SplitIndex{ siEvents, siDepth } = do + ix' <- if length siEvents > siDepth * storeEventsThreshold + then mergeEvents ix + else pure ix + pure ix' { siEvents = e : siEvents } + +mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) +mergeEvents ix@SplitIndex { siEvents, siDepth, siStore, siHandle } = do + let liveEs = take siDepth siEvents + storedEs = drop siDepth siEvents + h <- siHandle + nextStore <- siStore h storedEs + pure $ ix { siHandle = pure nextStore + , siEvents = liveEs + } + +insertL :: Monad m => [e] -> SplitIndex m a e -> m (SplitIndex m a e) +insertL es ix = foldlM (flip insert) ix es + +view :: SplitIndex m a e -> SplitIndexView m a e +view = siView + +historyLength :: SplitIndex m a e -> Int +historyLength SplitIndex { siDepth, siEvents } = + min siDepth (length siEvents) + +rewind :: Int -> SplitIndex m a e -> SplitIndex m a e +rewind n ix@SplitIndex { siEvents } = + ix { siEvents = drop n siEvents } diff --git a/src/Index/Stored.hs b/src/Index/Stored.hs deleted file mode 100644 index 9ccf10ecc0..0000000000 --- a/src/Index/Stored.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Index.Stored - ( StoredIndex - , new - , insert - , insertL - , view - , historyLength - , rewind - ) where - -import Data.Foldable (foldlM) - -data StoredIndex m a e = StoredIndex - { siHandle :: m a - , siEvents :: [e] - , siDepth :: Int - , siStore :: a -> [e] -> m a - } - -storeEventsThreshold :: Int -storeEventsThreshold = 3 - -new :: Monad m => (a -> [e] -> m a) -> Int -> m a -> Maybe (StoredIndex m a e) -new store depth acc - | depth <= 0 = Nothing - | otherwise = Just $ StoredIndex - { siHandle = acc - , siEvents = [] - , siDepth = depth - , siStore = store - } - -insert :: Monad m => e -> StoredIndex m a e -> m (StoredIndex m a e) -insert e ix@StoredIndex{ siEvents, siDepth } = do - ix' <- if length siEvents > siDepth * storeEventsThreshold - then mergeEvents ix - else pure ix - pure ix' { siEvents = e : siEvents } - -mergeEvents :: Monad m => StoredIndex m a e -> m (StoredIndex m a e) -mergeEvents ix@StoredIndex { siEvents, siDepth, siStore, siHandle } = do - let liveEs = take siDepth siEvents - storedEs = drop siDepth siEvents - h <- siHandle - nextStore <- siStore h storedEs - pure $ ix { siHandle = pure nextStore - , siEvents = liveEs - } - -insertL :: Monad m => [e] -> StoredIndex m a e -> m (StoredIndex m a e) -insertL es ix = foldlM (flip insert) ix es - -view :: StoredIndex m a e -> m a -view = siHandle - -historyLength :: StoredIndex m a e -> Int -historyLength StoredIndex { siDepth, siEvents } = - min siDepth (length siEvents) - -rewind :: Int -> StoredIndex m a e -> StoredIndex m a e -rewind n ix@StoredIndex { siEvents } = - ix { siEvents = drop n siEvents } From c9970f9b9b7115df996ff66a59867900be5e00da Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 23 Feb 2022 11:52:42 +0200 Subject: [PATCH 26/62] Refactoring of the Split index. --- src/Index.hs | 75 ++++++++++++++++++++++------------------------ src/Index/Split.hs | 39 ++++++++++++++---------- test/Spec.hs | 20 ++++++------- 3 files changed, 69 insertions(+), 65 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index d1fd518204..6d87212ef0 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveAnyClass #-} - module Index - ( Index + ( Index(..) -- * Constructors , new , insert @@ -16,8 +13,8 @@ module Index , insertL , matches -- * Testing - , ObservedIndex (..) - , GrammarIndex (..) + , ObservedBuilder (..) + , GrammarBuilder (..) , ixSignature ) where @@ -31,19 +28,19 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, import QuickSpec import GHC.Generics -data Index a b = New (a -> b -> a) Int a - | Insert b (Index a b) - | Rewind Int (Index a b) +data Index a e = New (a -> e -> a) Int a + | Insert e (Index a e) + | Rewind Int (Index a e) -instance (Show a, Show b) => Show (Index a b) where +instance (Show a, Show e) => Show (Index a e) where show (New f depth acc) = "New " <> show depth <> " " <> show acc show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" -newtype GrammarIndex a b = GrammarIndex (Index a b) +newtype GrammarBuilder a e = GrammarBuilder (Index a e) deriving (Show) -newtype ObservedIndex a b = ObservedIndex (Index a b) +newtype ObservedBuilder a e = ObservedBuilder (Index a e) deriving (Show) data IndexView a = IndexView @@ -54,15 +51,15 @@ data IndexView a = IndexView -- | Constructors -new :: (a -> b -> a) -> Int -> a -> Maybe (Index a b) +new :: (a -> e -> a) -> Int -> a -> Maybe (Index a e) new f depth initial | depth > 0 = Just $ New f depth initial | otherwise = Nothing -insert :: b -> Index a b -> Index a b +insert :: e -> Index a e -> Index a e insert = Insert -rewind :: Int -> Index a b -> Maybe (Index a b) +rewind :: Int -> Index a e -> Maybe (Index a e) rewind n ix | ixDepth (view ix) <= n = Nothing | ixSize (view ix) < n = Nothing @@ -70,16 +67,16 @@ rewind n ix -- | Observations -view :: Index a b -> IndexView a +view :: Index a e -> IndexView a view (New f depth initial) = IndexView { ixDepth = depth , ixView = initial , ixSize = 0 } -view (Insert b ix) = +view (Insert e ix) = let f = getFunction ix v = view ix - in v { ixView = f (ixView v) b + in v { ixView = f (ixView v) e , ixSize = min (ixDepth v) (ixSize v + 1) } view (Rewind n ix) = @@ -91,23 +88,23 @@ view (Rewind n ix) = -- | Internal -getFunction :: Index a b -> (a -> b -> a) +getFunction :: Index a e -> (a -> e -> a) getFunction (New f _ _) = f getFunction (Insert _ ix) = getFunction ix getFunction (Rewind _ ix) = getFunction ix -getHistory :: Index a b -> [a] +getHistory :: Index a e -> [a] getHistory (New _ _ i) = [i] -getHistory (Insert b ix) = +getHistory (Insert e ix) = let f = getFunction ix h = getHistory ix v = view ix - in f (head h) b : take (ixDepth v - 1) h + in f (head h) e : take (ixDepth v - 1) h getHistory (Rewind n ix) = drop n $ getHistory ix -- | Utility -matches :: Eq a => Index a b -> Index a b -> Bool +matches :: Eq a => Index a e -> Index a e -> Bool matches hl hr = let hlAccumulator = getHistory hl hrAccumulator = getHistory hr @@ -115,14 +112,14 @@ matches hl hr = || hrAccumulator `isInfixOf` hlAccumulator || hrAccumulator == hlAccumulator -insertL :: [b] -> Index a b -> Index a b -insertL bs ix = foldl' (flip insert) ix bs +insertL :: [e] -> Index a e -> Index a e +insertL es ix = foldl' (flip insert) ix es -- | QuickCheck instance ( CoArbitrary a - , CoArbitrary b + , CoArbitrary e , Arbitrary a - , Arbitrary b ) => Arbitrary (ObservedIndex a b) where + , Arbitrary e ) => Arbitrary (ObservedBuilder a e) where arbitrary = sized $ \n -> do depth <- frequency [ (05, pure 1) -- overfill , (40, chooseInt (2, n + 2)) -- about filled @@ -141,21 +138,21 @@ instance ( CoArbitrary a -- Construction can only fail due to NonPositive depth -- Tested with prop_hfNewReturns... let newHf = fromJust $ new fn depth acc - pure . ObservedIndex $ insertL bs newHf + pure . ObservedBuilder $ insertL bs newHf instance ( CoArbitrary a - , CoArbitrary b + , CoArbitrary e , Arbitrary a - , Arbitrary b ) => Arbitrary (Index a b) where + , Arbitrary e ) => Arbitrary (Index a e) where -- Use the ObservedIndex instance as a generator for Indexes arbitrary = do - (ObservedIndex ix) <- arbitrary + (ObservedBuilder ix) <- arbitrary pure ix instance ( CoArbitrary a - , CoArbitrary b + , CoArbitrary e , Arbitrary a - , Arbitrary b ) => Arbitrary (GrammarIndex a b) where + , Arbitrary e ) => Arbitrary (GrammarBuilder a e) where arbitrary = sized $ \n -> do depth <- frequency [ (05, pure 1) -- overfill , (40, chooseInt (2, n + 2)) -- about filled @@ -167,8 +164,8 @@ instance ( CoArbitrary a complexity <- arbitrarySizedIntegral generateGrammarIndex complexity ix -generateGrammarIndex :: Arbitrary b => Int -> Index a b -> Gen (GrammarIndex a b) -generateGrammarIndex 0 ix = pure $ GrammarIndex ix +generateGrammarIndex :: Arbitrary e => Int -> Index a e -> Gen (GrammarBuilder a e) +generateGrammarIndex 0 ix = pure $ GrammarBuilder ix generateGrammarIndex n ix = do b <- arbitrary n <- chooseInt (1, ixDepth $ view ix) @@ -189,17 +186,17 @@ instance Arbitrary a => Arbitrary (IndexView a) where -- | QuickSpec -newtype IxEvents b = IxEvents [b] +newtype IxEvents e = IxEvents [e] deriving (Eq, Ord, Typeable) -instance Arbitrary b => Arbitrary (IxEvents b) where +instance Arbitrary e => Arbitrary (IxEvents e) where arbitrary = IxEvents <$> listOf arbitrary instance ( Ord a , Arbitrary a - , Arbitrary b + , Arbitrary e , CoArbitrary a - , CoArbitrary b) => Observe (IxEvents b) (IndexView a) (Index a b) where + , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e) where observe (IxEvents es) ix = view $ insertL es ix ixSignature :: [Sig] diff --git a/src/Index/Split.hs b/src/Index/Split.hs index cb39da6951..1c444d7ad6 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -2,46 +2,43 @@ {-# LANGUAGE RankNTypes #-} module Index.Split - ( SplitIndex + ( -- * API + SplitIndex , new , insert , insertL - , view - , historyLength + , size , rewind ) where import Data.Foldable (foldlM) +import Index (Index (..), IndexView(..)) +import qualified Index as Ix + data SplitIndex m a e = SplitIndex { siHandle :: m a , siEvents :: [e] , siDepth :: Int , siStore :: a -> [e] -> m a - , siView :: forall b. (SplitIndex m a e -> m b) -> SplitIndex m a e -> m b } -type SplitIndexView m a e = - forall b. (SplitIndex m a e -> m b) -> SplitIndex m a e -> m b - storeEventsThreshold :: Int storeEventsThreshold = 3 new :: Monad m - => SplitIndexView m a e - -> (a -> [e] -> m a) + => (a -> [e] -> m a) -> Int -> m a -> Maybe (SplitIndex m a e) -new view store depth acc +new store depth acc | depth <= 0 = Nothing | otherwise = Just $ SplitIndex { siHandle = acc , siEvents = [] , siDepth = depth , siStore = store - , siView = view } insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) @@ -64,13 +61,23 @@ mergeEvents ix@SplitIndex { siEvents, siDepth, siStore, siHandle } = do insertL :: Monad m => [e] -> SplitIndex m a e -> m (SplitIndex m a e) insertL es ix = foldlM (flip insert) ix es -view :: SplitIndex m a e -> SplitIndexView m a e -view = siView - -historyLength :: SplitIndex m a e -> Int -historyLength SplitIndex { siDepth, siEvents } = +size :: SplitIndex m a e -> Int +size SplitIndex { siDepth, siEvents } = min siDepth (length siEvents) rewind :: Int -> SplitIndex m a e -> SplitIndex m a e rewind n ix@SplitIndex { siEvents } = ix { siEvents = drop n siEvents } + +-- | Using Split as an interpretation of Index + +toIndexView :: Monad m => SplitIndex m a e -> m (IndexView a) +toIndexView si@SplitIndex{siHandle, siDepth, siStore, siEvents} = do + h <- siHandle + v <- siStore h siEvents + pure $ IndexView { ixDepth = siDepth + , ixSize = size si + , ixView = v + } + + diff --git a/test/Spec.hs b/test/Spec.hs index e5b7f2de97..a9e5cb3357 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -46,9 +46,9 @@ prop_hfNewReturn f acc = -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (hfDepth hf == 1) prop_rewindWithDepth - :: ObservedIndex a b + :: ObservedBuilder a b -> Property -prop_rewindWithDepth (ObservedIndex ix) = +prop_rewindWithDepth (ObservedBuilder ix) = let v = view ix in ixDepth v >= 2 ==> forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) @@ -67,18 +67,18 @@ prop_rewindWithDepth (ObservedIndex ix) = -- | Property that validates the HF data structure. prop_historyLengthLEDepth - :: ObservedIndex a b + :: ObservedBuilder a b -> Property -prop_historyLengthLEDepth (ObservedIndex ix) = +prop_historyLengthLEDepth (ObservedBuilder ix) = let v = view ix in property $ ixSize v <= ixDepth v -- | Relation between Rewind and Inverse prop_InsertRewindInverse :: (Show a, Show b, Arbitrary b, Eq a) - => ObservedIndex a b + => ObservedBuilder a b -> Property -prop_InsertRewindInverse (ObservedIndex ix) = +prop_InsertRewindInverse (ObservedBuilder ix) = let v = view ix -- rewind does not make sense for lesser depths. in ixDepth v >= 2 ==> @@ -96,18 +96,18 @@ prop_InsertRewindInverse (ObservedIndex ix) = -- another implmentation is confirming. prop_InsertFolds :: (Eq a, Show a) - => ObservedIndex a b + => ObservedBuilder a b -> [b] -> Property -prop_InsertFolds (ObservedIndex ix) bs = +prop_InsertFolds (ObservedBuilder ix) bs = ixView (view (insertL bs ix)) === foldl' (getFunction ix) (ixView $ view ix) bs prop_InsertHistoryLength - :: ObservedIndex a b + :: ObservedBuilder a b -> b -> Property -prop_InsertHistoryLength (ObservedIndex ix) b = +prop_InsertHistoryLength (ObservedBuilder ix) b = let v = view ix initialLength = ixSize v finalLength = ixSize . view $ insert b ix From 89d71e3af791b5d72899489d2484f592d81ea674 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 23 Feb 2022 12:22:26 +0200 Subject: [PATCH 27/62] Add interpretation for Index using SplitIndex. --- hysterical-screams.cabal | 2 ++ package.yaml | 1 + src/Index/Split.hs | 14 ++++++++++++-- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 40e88222d7..9434a6f8c2 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -37,6 +37,7 @@ library default-extensions: ImportQualifiedPost ExplicitForAll + ScopedTypeVariables TypeApplications PatternSynonyms DeriveGeneric @@ -59,6 +60,7 @@ test-suite hysterical-screams-test default-extensions: ImportQualifiedPost ExplicitForAll + ScopedTypeVariables TypeApplications PatternSynonyms DeriveGeneric diff --git a/package.yaml b/package.yaml index b93eddc3d8..9e0c81037f 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ description: Please see the README on GitHub at Index a e -> m (SplitIndex m a e) +fromIndex (Ix.New f depth acc) = + pure $ fromJust $ new merge depth (pure acc) + where + merge :: Monad m => a -> [e] -> m a + merge acc es = pure $ foldl' f acc es +fromIndex (Ix.Insert e ix) = insert e =<< fromIndex ix +fromIndex (Ix.Rewind n ix) = rewind n <$> fromIndex ix From 9d1bb99ed1a639eb5bccc9adf4c526970a7fc726 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 1 Mar 2022 07:22:34 +0200 Subject: [PATCH 28/62] Review laws and refactoring. --- src/Index.hs | 39 +++++++++++++++++++-------- test/Spec.hs | 76 +++++++++++++++++++++++++++++++++------------------- 2 files changed, 77 insertions(+), 38 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 6d87212ef0..507afde58f 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -11,7 +11,6 @@ module Index , getHistory -- * Helpers , insertL - , matches -- * Testing , ObservedBuilder (..) , GrammarBuilder (..) @@ -20,7 +19,6 @@ module Index import Control.Monad (replicateM) import Data.Foldable (foldl') -import Data.List (isInfixOf) import Data.Maybe (fromJust) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, arbitrarySizedIntegral, choose, chooseInt, @@ -28,6 +26,33 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, import QuickSpec import GHC.Generics +{- | Laws + Constructors: new, insert, rewind + Observations: view [depth, view, size], getHistory, getFunction + + Laws derived by constructors/observations: + + view (new f d a) = + | d > 0 = IndexView [d a 0] + | otherwise = Nothing + getHistory (new f d a) = [] + view (insertL bs (new f d a)) = IndexView [d (foldl' f a bs) (max (length bs) d)] + getHistory (insertL bs (new f d a)) = take d bs + view (rewind n (new f d a)) = Nothing + view (rewind n (insertL bs (new f d a))) = + | n <= length bs = IndexView [d a' ((max (length bs) d) - n)] + where a' = head $ drop n $ scanl' f a bs + | otherwise = nothing + getHistory (rewind n (insertL bs (new f d a))) = drop n $ scanl' f a bs + + Laws derived by interplay of constructors: + + d >= length bs => + obs (rewind (length bs) (insertL bs (new f d a))) = obs (new f d a) + rewind _ (new f d a) = Nothing + depth >= size +-} + data Index a e = New (a -> e -> a) Int a | Insert e (Index a e) | Rewind Int (Index a e) @@ -46,7 +71,7 @@ newtype ObservedBuilder a e = ObservedBuilder (Index a e) data IndexView a = IndexView { ixDepth :: Int , ixView :: a - , ixSize :: Int + , ixSize :: Int -- ^ Size represents the stored history elements } deriving (Show, Ord, Eq, Typeable, Generic) -- | Constructors @@ -104,14 +129,6 @@ getHistory (Rewind n ix) = drop n $ getHistory ix -- | Utility -matches :: Eq a => Index a e -> Index a e -> Bool -matches hl hr = - let hlAccumulator = getHistory hl - hrAccumulator = getHistory hr - in hlAccumulator `isInfixOf` hrAccumulator - || hrAccumulator `isInfixOf` hlAccumulator - || hrAccumulator == hlAccumulator - insertL :: [e] -> Index a e -> Index a e insertL es ix = foldl' (flip insert) ix es -- | QuickCheck diff --git a/test/Spec.hs b/test/Spec.hs index a9e5cb3357..79622a87ec 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,46 +2,57 @@ import QuickSpec import Test.Tasty import Test.Tasty.QuickCheck -import Data.List (foldl') +import Data.List (foldl', isInfixOf) import Data.Maybe (fromJust, isJust, isNothing) import Index +import qualified Debug.Trace as Debug + tests :: TestTree -tests = testGroup "Index" [hfProperties] +tests = testGroup "Index" [ixProperties] -hfProperties :: TestTree -hfProperties = testGroup "Basic model" +ixProperties :: TestTree +ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ prop_hfNewReturn @Int @Int + withMaxSuccess 10000 $ prop_newReturn @Int @Int , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ prop_historyLengthLEDepth @Int @Int + withMaxSuccess 10000 $ prop_sizeLEDepth @Int @Int , testProperty "Rewind: Connection with `hfDepth`" $ withMaxSuccess 10000 $ prop_rewindWithDepth @Int @Int , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ prop_InsertRewindInverse @Int @Int + withMaxSuccess 10000 $ prop_insertRewindInverse @Int @Int , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ prop_InsertFolds @Int @Int + withMaxSuccess 10000 $ prop_insertFolds @Int @Int , testProperty "Insert is increasing the length unless overflowing" $ - withMaxSuccess 10000 $ prop_InsertHistoryLength @Int @Int + withMaxSuccess 10000 $ prop_insertHistoryLength @Int @Int ] --- | Properties of the `new` operation. -prop_hfNewReturn - :: Fun (a, b) a +{- | Properties of the `new` operation. + view (new f d a) = + | d > 0 = IndexView [d a 0] + | otherwise = Nothing + getHistory (new f d a) = [] +-} +prop_newReturn + :: Eq a + => Fun (a, b) a -> a -> Property -prop_hfNewReturn f acc = +prop_newReturn f acc = forAll (frequency [ (10, pure 0) , (50, chooseInt (-100, 0)) , (50, chooseInt (1, 100)) ]) $ \depth -> cover 30 (depth < 0) "Negative depth" $ cover 30 (depth >= 0) "Non negative depth" $ - let newHF = new (applyFun2 f) depth acc + let newIx = new (applyFun2 f) depth acc in property $ if depth <= 0 - then isNothing newHF - else isJust newHF + then isNothing newIx + else view (fromJust newIx) == IndexView { ixDepth = depth + , ixView = acc + , ixSize = 0 + } -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (hfDepth hf == 1) @@ -66,19 +77,19 @@ prop_rewindWithDepth (ObservedBuilder ix) = else property $ isJust newIx -- | Property that validates the HF data structure. -prop_historyLengthLEDepth +prop_sizeLEDepth :: ObservedBuilder a b -> Property -prop_historyLengthLEDepth (ObservedBuilder ix) = +prop_sizeLEDepth (ObservedBuilder ix) = let v = view ix in property $ ixSize v <= ixDepth v -- | Relation between Rewind and Inverse -prop_InsertRewindInverse +prop_insertRewindInverse :: (Show a, Show b, Arbitrary b, Eq a) => ObservedBuilder a b -> Property -prop_InsertRewindInverse (ObservedBuilder ix) = +prop_insertRewindInverse (ObservedBuilder ix) = let v = view ix -- rewind does not make sense for lesser depths. in ixDepth v >= 2 ==> @@ -87,27 +98,30 @@ prop_InsertRewindInverse (ObservedBuilder ix) = -- than `hfDepth hf` forAll (resize (ixDepth v - 1) arbitrary) $ \bs -> - let ix' = rewind (length bs) $ insertL bs ix - v' = view (fromJust ix') - in property $ isJust ix' && fromJust ix' `matches` ix + let mix' = rewind (length bs) $ insertL bs ix + -- This should always be Just.. because of the resize of `bs` + ix' = fromJust mix' + v' = view ix' + in property $ ix `matches` ix' + -- && getHistory ix == getHistory ix' -- | Generally this would not be a good property since it is very coupled -- to the implementation, but it will be useful when trying to certify that -- another implmentation is confirming. -prop_InsertFolds +prop_insertFolds :: (Eq a, Show a) => ObservedBuilder a b -> [b] -> Property -prop_InsertFolds (ObservedBuilder ix) bs = +prop_insertFolds (ObservedBuilder ix) bs = ixView (view (insertL bs ix)) === foldl' (getFunction ix) (ixView $ view ix) bs -prop_InsertHistoryLength +prop_insertHistoryLength :: ObservedBuilder a b -> b -> Property -prop_InsertHistoryLength (ObservedBuilder ix) b = +prop_insertHistoryLength (ObservedBuilder ix) b = let v = view ix initialLength = ixSize v finalLength = ixSize . view $ insert b ix @@ -117,6 +131,14 @@ prop_InsertHistoryLength (ObservedBuilder ix) b = then finalLength === initialLength else finalLength === initialLength + 1 +matches :: Eq a => Index a e -> Index a e -> Bool +matches hl hr = + let hlAccumulator = getHistory hl + hrAccumulator = getHistory hr + in hlAccumulator `isInfixOf` hrAccumulator + || hrAccumulator `isInfixOf` hlAccumulator + || hrAccumulator == hlAccumulator + main :: IO () main = do -- quickSpec ixSignature From 79b0ebc1def6f2238c4a89e115719e52c27db9d7 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 1 Mar 2022 07:53:14 +0200 Subject: [PATCH 29/62] Fixed some size bugs. --- src/Index.hs | 4 ++-- test/Spec.hs | 44 ++++++++++++++++++++++++-------------------- 2 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 507afde58f..93b2ad9596 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -35,7 +35,7 @@ import GHC.Generics view (new f d a) = | d > 0 = IndexView [d a 0] | otherwise = Nothing - getHistory (new f d a) = [] + getHistory (new f d a) = [a] view (insertL bs (new f d a)) = IndexView [d (foldl' f a bs) (max (length bs) d)] getHistory (insertL bs (new f d a)) = take d bs view (rewind n (new f d a)) = Nothing @@ -96,7 +96,7 @@ view :: Index a e -> IndexView a view (New f depth initial) = IndexView { ixDepth = depth , ixView = initial - , ixSize = 0 + , ixSize = 1 } view (Insert e ix) = let f = getFunction ix diff --git a/test/Spec.hs b/test/Spec.hs index 79622a87ec..269ec8665d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,7 @@ import QuickSpec import Test.Tasty import Test.Tasty.QuickCheck -import Data.List (foldl', isInfixOf) +import Data.List (foldl', isInfixOf, null) import Data.Maybe (fromJust, isJust, isNothing) import Index @@ -15,17 +15,17 @@ tests = testGroup "Index" [ixProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ prop_newReturn @Int @Int + withMaxSuccess 10000 $ prop_observeNew @Int @Int , testProperty "History length is always smaller than the max depth" $ withMaxSuccess 10000 $ prop_sizeLEDepth @Int @Int - , testProperty "Rewind: Connection with `hfDepth`" $ - withMaxSuccess 10000 $ prop_rewindWithDepth @Int @Int + , testProperty "Rewind: Connection with `ixDepth`" $ + withMaxSuccess 10000 $ prop_rewindDepth @Int @Int , testProperty "Relationship between Insert/Rewind" $ withMaxSuccess 10000 $ prop_insertRewindInverse @Int @Int , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ prop_insertFolds @Int @Int + withMaxSuccess 10000 $ prop_observeInsert @Int @Int , testProperty "Insert is increasing the length unless overflowing" $ - withMaxSuccess 10000 $ prop_insertHistoryLength @Int @Int + withMaxSuccess 10000 $ prop_insertSize @Int @Int ] {- | Properties of the `new` operation. @@ -34,12 +34,12 @@ ixProperties = testGroup "Basic model" | otherwise = Nothing getHistory (new f d a) = [] -} -prop_newReturn - :: Eq a +prop_observeNew + :: (Eq a, Show a) => Fun (a, b) a -> a -> Property -prop_newReturn f acc = +prop_observeNew f acc = forAll (frequency [ (10, pure 0) , (50, chooseInt (-100, 0)) , (50, chooseInt (1, 100)) ]) $ @@ -51,15 +51,16 @@ prop_newReturn f acc = then isNothing newIx else view (fromJust newIx) == IndexView { ixDepth = depth , ixView = acc - , ixSize = 0 + , ixSize = 1 } + && getHistory (fromJust newIx) == [acc] -- | Properties of the connection between rewind and depth --- Note: Cannot rewind if (hfDepth hf == 1) -prop_rewindWithDepth +-- Note: Cannot rewind if (ixDepth ix == 1) +prop_rewindDepth :: ObservedBuilder a b -> Property -prop_rewindWithDepth (ObservedBuilder ix) = +prop_rewindDepth (ObservedBuilder ix) = let v = view ix in ixDepth v >= 2 ==> forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) @@ -103,25 +104,28 @@ prop_insertRewindInverse (ObservedBuilder ix) = ix' = fromJust mix' v' = view ix' in property $ ix `matches` ix' - -- && getHistory ix == getHistory ix' -- | Generally this would not be a good property since it is very coupled -- to the implementation, but it will be useful when trying to certify that -- another implmentation is confirming. -prop_insertFolds +prop_observeInsert :: (Eq a, Show a) => ObservedBuilder a b -> [b] -> Property -prop_insertFolds (ObservedBuilder ix) bs = - ixView (view (insertL bs ix)) === - foldl' (getFunction ix) (ixView $ view ix) bs +prop_observeInsert (ObservedBuilder ix) bs = + let v = view ix + in view (insertL bs ix) === + IndexView { ixDepth = ixDepth v + , ixSize = min (ixDepth v) (length bs + ixSize v) + , ixView = foldl' (getFunction ix) (ixView $ view ix) bs + } -prop_insertHistoryLength +prop_insertSize :: ObservedBuilder a b -> b -> Property -prop_insertHistoryLength (ObservedBuilder ix) b = +prop_insertSize (ObservedBuilder ix) b = let v = view ix initialLength = ixSize v finalLength = ixSize . view $ insert b ix From 0a42e8ef2114a805691a7eda2293f1aa036d16e8 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 4 Mar 2022 14:01:35 +0700 Subject: [PATCH 30/62] Refactoring. * Refactor some property tests making them more exact. * Bump stackage version. --- src/Index.hs | 4 ++-- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- test/Spec.hs | 15 ++++----------- 4 files changed, 11 insertions(+), 18 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 93b2ad9596..04ecd37688 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -38,8 +38,8 @@ import GHC.Generics getHistory (new f d a) = [a] view (insertL bs (new f d a)) = IndexView [d (foldl' f a bs) (max (length bs) d)] getHistory (insertL bs (new f d a)) = take d bs - view (rewind n (new f d a)) = Nothing - view (rewind n (insertL bs (new f d a))) = + rewind n (new f d a) = Nothing + view <$> (rewind n (insertL bs (new f d a))) = | n <= length bs = IndexView [d a' ((max (length bs) d) - n)] where a' = head $ drop n $ scanl' f a bs | otherwise = nothing diff --git a/stack.yaml b/stack.yaml index 2562271b2d..6fae039572 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index dc1a879cf4..3f6958bea8 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -20,8 +20,8 @@ packages: hackage: twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 snapshots: - completed: - sha256: 1b74fb5e970497b5aefae56703f1bd44aa648bd1a5ef95c1eb8c29775087e2bf - size: 587393 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml + sha256: 79a786674930a89301b0e908fad2822a48882f3d01486117693c377b8edffdbe + size: 590102 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml diff --git a/test/Spec.hs b/test/Spec.hs index 269ec8665d..ceea0048c0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -101,9 +101,10 @@ prop_insertRewindInverse (ObservedBuilder ix) = \bs -> let mix' = rewind (length bs) $ insertL bs ix -- This should always be Just.. because of the resize of `bs` - ix' = fromJust mix' - v' = view ix' - in property $ ix `matches` ix' + ix' = fromJust mix' + h = take (ixDepth v - length bs) $ getHistory ix + h' = getHistory ix' + in property $ h == h' -- | Generally this would not be a good property since it is very coupled -- to the implementation, but it will be useful when trying to certify that @@ -135,14 +136,6 @@ prop_insertSize (ObservedBuilder ix) b = then finalLength === initialLength else finalLength === initialLength + 1 -matches :: Eq a => Index a e -> Index a e -> Bool -matches hl hr = - let hlAccumulator = getHistory hl - hrAccumulator = getHistory hr - in hlAccumulator `isInfixOf` hrAccumulator - || hrAccumulator `isInfixOf` hlAccumulator - || hrAccumulator == hlAccumulator - main :: IO () main = do -- quickSpec ixSignature From a0e96a315d2f88b6ce79ec6cea2d576b209efc1c Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 4 Mar 2022 14:45:40 +0700 Subject: [PATCH 31/62] Move the Index tests from Spec. --- hysterical-screams.cabal | 1 + test/Spec.hs | 126 +++------------------------------------ test/Spec/Index.hs | 118 ++++++++++++++++++++++++++++++++++++ 3 files changed, 126 insertions(+), 119 deletions(-) create mode 100644 test/Spec/Index.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 9434a6f8c2..674f569aec 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -54,6 +54,7 @@ test-suite hysterical-screams-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Spec.Index Paths_hysterical_screams hs-source-dirs: test diff --git a/test/Spec.hs b/test/Spec.hs index ceea0048c0..6fe3c5d0e3 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,7 @@ -import QuickSpec import Test.Tasty import Test.Tasty.QuickCheck -import Data.List (foldl', isInfixOf, null) -import Data.Maybe (fromJust, isJust, isNothing) - -import Index +import qualified Spec.Index as Ix import qualified Debug.Trace as Debug @@ -15,127 +11,19 @@ tests = testGroup "Index" [ixProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ prop_observeNew @Int @Int + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ prop_sizeLEDepth @Int @Int + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int , testProperty "Rewind: Connection with `ixDepth`" $ - withMaxSuccess 10000 $ prop_rewindDepth @Int @Int + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ prop_insertRewindInverse @Int @Int + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ prop_observeInsert @Int @Int + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int , testProperty "Insert is increasing the length unless overflowing" $ - withMaxSuccess 10000 $ prop_insertSize @Int @Int + withMaxSuccess 10000 $ Ix.prop_insertSize @Int @Int ] -{- | Properties of the `new` operation. - view (new f d a) = - | d > 0 = IndexView [d a 0] - | otherwise = Nothing - getHistory (new f d a) = [] --} -prop_observeNew - :: (Eq a, Show a) - => Fun (a, b) a - -> a - -> Property -prop_observeNew f acc = - forAll (frequency [ (10, pure 0) - , (50, chooseInt (-100, 0)) - , (50, chooseInt (1, 100)) ]) $ - \depth -> - cover 30 (depth < 0) "Negative depth" $ - cover 30 (depth >= 0) "Non negative depth" $ - let newIx = new (applyFun2 f) depth acc - in property $ if depth <= 0 - then isNothing newIx - else view (fromJust newIx) == IndexView { ixDepth = depth - , ixView = acc - , ixSize = 1 - } - && getHistory (fromJust newIx) == [acc] - --- | Properties of the connection between rewind and depth --- Note: Cannot rewind if (ixDepth ix == 1) -prop_rewindDepth - :: ObservedBuilder a b - -> Property -prop_rewindDepth (ObservedBuilder ix) = - let v = view ix in - ixDepth v >= 2 ==> - forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) - , (30, chooseInt (ixSize v + 1, ixDepth v - 1)) - , (50, chooseInt (1, ixSize v)) ]) $ - \depth -> - cover 15 (depth > ixDepth v) "Depth is larger than max depth." $ - cover 15 (depth <= ixDepth v && depth > ixSize v) - "Depth is lower than max but there is not enough data." $ - cover 40 (depth <= ixDepth v && depth <= ixSize v) - "Depth is properly set." $ - let newIx = rewind depth ix - in if depth > (ixDepth v - 1) || (depth > ixSize v) - then property $ isNothing newIx - else property $ isJust newIx - --- | Property that validates the HF data structure. -prop_sizeLEDepth - :: ObservedBuilder a b - -> Property -prop_sizeLEDepth (ObservedBuilder ix) = - let v = view ix - in property $ ixSize v <= ixDepth v - --- | Relation between Rewind and Inverse -prop_insertRewindInverse - :: (Show a, Show b, Arbitrary b, Eq a) - => ObservedBuilder a b - -> Property -prop_insertRewindInverse (ObservedBuilder ix) = - let v = view ix - -- rewind does not make sense for lesser depths. - in ixDepth v >= 2 ==> - -- if the history is not fully re-written, then we can get a common - -- prefix after the insert/rewind play. We need input which is less - -- than `hfDepth hf` - forAll (resize (ixDepth v - 1) arbitrary) $ - \bs -> - let mix' = rewind (length bs) $ insertL bs ix - -- This should always be Just.. because of the resize of `bs` - ix' = fromJust mix' - h = take (ixDepth v - length bs) $ getHistory ix - h' = getHistory ix' - in property $ h == h' - --- | Generally this would not be a good property since it is very coupled --- to the implementation, but it will be useful when trying to certify that --- another implmentation is confirming. -prop_observeInsert - :: (Eq a, Show a) - => ObservedBuilder a b - -> [b] - -> Property -prop_observeInsert (ObservedBuilder ix) bs = - let v = view ix - in view (insertL bs ix) === - IndexView { ixDepth = ixDepth v - , ixSize = min (ixDepth v) (length bs + ixSize v) - , ixView = foldl' (getFunction ix) (ixView $ view ix) bs - } - -prop_insertSize - :: ObservedBuilder a b - -> b - -> Property -prop_insertSize (ObservedBuilder ix) b = - let v = view ix - initialLength = ixSize v - finalLength = ixSize . view $ insert b ix - in cover 10 (initialLength == ixDepth v) "Overflowing" $ - cover 30 (initialLength < ixDepth v) "Not filled" $ - if initialLength == ixDepth v - then finalLength === initialLength - else finalLength === initialLength + 1 - main :: IO () main = do -- quickSpec ixSignature diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs new file mode 100644 index 0000000000..8a66ce6452 --- /dev/null +++ b/test/Spec/Index.hs @@ -0,0 +1,118 @@ +module Spec.Index where + +import QuickSpec +import Test.Tasty +import Test.Tasty.QuickCheck +import Data.Maybe (fromJust, isJust, isNothing) +import Data.List (foldl') + +import Index + +{- | Properties of the `new` operation. + view (new f d a) = + | d > 0 = IndexView [d a 0] + | otherwise = Nothing + getHistory (new f d a) = [] +-} +prop_observeNew + :: (Eq a, Show a) + => Fun (a, b) a + -> a + -> Property +prop_observeNew f acc = + forAll (frequency [ (10, pure 0) + , (50, chooseInt (-100, 0)) + , (50, chooseInt (1, 100)) ]) $ + \depth -> + cover 30 (depth < 0) "Negative depth" $ + cover 30 (depth >= 0) "Non negative depth" $ + let newIx = new (applyFun2 f) depth acc + in property $ if depth <= 0 + then isNothing newIx + else view (fromJust newIx) == IndexView { ixDepth = depth + , ixView = acc + , ixSize = 1 + } + && getHistory (fromJust newIx) == [acc] + +-- | Properties of the connection between rewind and depth +-- Note: Cannot rewind if (ixDepth ix == 1) +prop_rewindDepth + :: ObservedBuilder a b + -> Property +prop_rewindDepth (ObservedBuilder ix) = + let v = view ix in + ixDepth v >= 2 ==> + forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) + , (30, chooseInt (ixSize v + 1, ixDepth v - 1)) + , (50, chooseInt (1, ixSize v)) ]) $ + \depth -> + cover 15 (depth > ixDepth v) "Depth is larger than max depth." $ + cover 15 (depth <= ixDepth v && depth > ixSize v) + "Depth is lower than max but there is not enough data." $ + cover 40 (depth <= ixDepth v && depth <= ixSize v) + "Depth is properly set." $ + let newIx = rewind depth ix + in if depth > (ixDepth v - 1) || (depth > ixSize v) + then property $ isNothing newIx + else property $ isJust newIx + +-- | Property that validates the HF data structure. +prop_sizeLEDepth + :: ObservedBuilder a b + -> Property +prop_sizeLEDepth (ObservedBuilder ix) = + let v = view ix + in property $ ixSize v <= ixDepth v + +-- | Relation between Rewind and Inverse +prop_insertRewindInverse + :: (Show a, Show b, Arbitrary b, Eq a) + => ObservedBuilder a b + -> Property +prop_insertRewindInverse (ObservedBuilder ix) = + let v = view ix + -- rewind does not make sense for lesser depths. + in ixDepth v >= 2 ==> + -- if the history is not fully re-written, then we can get a common + -- prefix after the insert/rewind play. We need input which is less + -- than `hfDepth hf` + forAll (resize (ixDepth v - 1) arbitrary) $ + \bs -> + let mix' = rewind (length bs) $ insertL bs ix + -- This should always be Just.. because of the resize of `bs` + ix' = fromJust mix' + h = take (ixDepth v - length bs) $ getHistory ix + h' = getHistory ix' + in property $ h == h' + +-- | Generally this would not be a good property since it is very coupled +-- to the implementation, but it will be useful when trying to certify that +-- another implmentation is confirming. +prop_observeInsert + :: (Eq a, Show a) + => ObservedBuilder a b + -> [b] + -> Property +prop_observeInsert (ObservedBuilder ix) bs = + let v = view ix + in view (insertL bs ix) === + IndexView { ixDepth = ixDepth v + , ixSize = min (ixDepth v) (length bs + ixSize v) + , ixView = foldl' (getFunction ix) (ixView $ view ix) bs + } + +prop_insertSize + :: ObservedBuilder a b + -> b + -> Property +prop_insertSize (ObservedBuilder ix) b = + let v = view ix + initialLength = ixSize v + finalLength = ixSize . view $ insert b ix + in cover 10 (initialLength == ixDepth v) "Overflowing" $ + cover 30 (initialLength < ixDepth v) "Not filled" $ + if initialLength == ixDepth v + then finalLength === initialLength + else finalLength === initialLength + 1 + From 028729d51f695812f5aeebebf498dd29836d2ca6 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 4 Mar 2022 16:53:28 +0700 Subject: [PATCH 32/62] Generalize the new tests. --- test/Spec.hs | 12 ++++++++--- test/Spec/Index.hs | 51 ++++++++++++++++++++++++++++++---------------- 2 files changed, 42 insertions(+), 21 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 6fe3c5d0e3..4e81d7a2b2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,14 @@ +import Data.Maybe (fromJust, isJust, isNothing) +import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck -import qualified Spec.Index as Ix +import Index (Index, IndexView (..)) +import qualified Index as Ix +import qualified Spec.Index as Ix +import qualified Index.Split as S -import qualified Debug.Trace as Debug +import qualified Debug.Trace as Debug tests :: TestTree tests = testGroup "Index" [ixProperties] @@ -11,7 +16,7 @@ tests = testGroup "Index" [ixProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int Ix.conversion , testProperty "History length is always smaller than the max depth" $ withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int , testProperty "Rewind: Connection with `ixDepth`" $ @@ -24,6 +29,7 @@ ixProperties = testGroup "Basic model" withMaxSuccess 10000 $ Ix.prop_insertSize @Int @Int ] + main :: IO () main = do -- quickSpec ixSignature diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 8a66ce6452..5e5faf908c 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -3,37 +3,52 @@ module Spec.Index where import QuickSpec import Test.Tasty import Test.Tasty.QuickCheck +import Test.QuickCheck.Monadic import Data.Maybe (fromJust, isJust, isNothing) import Data.List (foldl') +import Data.Functor.Identity (Identity, runIdentity) import Index -{- | Properties of the `new` operation. - view (new f d a) = - | d > 0 = IndexView [d a 0] - | otherwise = Nothing - getHistory (new f d a) = [] --} +data Conversion m a e = Conversion + { cView :: Index a e -> m (IndexView a) + , cHistory :: Index a e -> m [a] + , cMonadic :: m Property -> Property + } + +conversion :: Conversion Identity a e +conversion = Conversion + { cView = pure . view + , cHistory = pure . getHistory + , cMonadic = runIdentity + } + prop_observeNew - :: (Eq a, Show a) - => Fun (a, b) a + :: forall e a m. (Eq a, Monad m) + => Conversion m a e + -> Fun (a, e) a -> a -> Property -prop_observeNew f acc = +prop_observeNew c f a = forAll (frequency [ (10, pure 0) , (50, chooseInt (-100, 0)) , (50, chooseInt (1, 100)) ]) $ \depth -> cover 30 (depth < 0) "Negative depth" $ - cover 30 (depth >= 0) "Non negative depth" $ - let newIx = new (applyFun2 f) depth acc - in property $ if depth <= 0 - then isNothing newIx - else view (fromJust newIx) == IndexView { ixDepth = depth - , ixView = acc - , ixSize = 1 - } - && getHistory (fromJust newIx) == [acc] + cover 30 (depth >= 0) "Non-negative depth" $ + let mix = new (applyFun2 f) depth a + in if depth <= 0 + -- Note: This is not testing construction of the monadic index + then property $ isNothing mix + else monadic (cMonadic c) $ do + let ix = fromJust mix + v <- run $ cView c ix + h <- run $ cHistory c ix + assert $ v == IndexView { ixDepth = depth + , ixView = a + , ixSize = 1 + } + && h == [a] -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) From fdfe2b3f61f68a319109afa4c34f958f374029f3 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 7 Mar 2022 09:59:49 +0700 Subject: [PATCH 33/62] Building the syntax should not fail. Fail when interpreting the syntax. This way more of the semantics can be tested. --- src/Index.hs | 89 ++++++++++++++++++++++++---------------------- test/Spec/Index.hs | 71 ++++++++++++++++++------------------ 2 files changed, 83 insertions(+), 77 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 04ecd37688..fab74d0eb6 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -76,40 +76,39 @@ data IndexView a = IndexView -- | Constructors -new :: (a -> e -> a) -> Int -> a -> Maybe (Index a e) -new f depth initial - | depth > 0 = Just $ New f depth initial - | otherwise = Nothing +new :: (a -> e -> a) -> Int -> a -> Index a e +new = New insert :: e -> Index a e -> Index a e insert = Insert -rewind :: Int -> Index a e -> Maybe (Index a e) -rewind n ix - | ixDepth (view ix) <= n = Nothing - | ixSize (view ix) < n = Nothing - | otherwise = Just $ Rewind n ix +rewind :: Int -> Index a e -> Index a e +rewind = Rewind -- | Observations -view :: Index a e -> IndexView a +view :: Index a e -> Maybe (IndexView a) view (New f depth initial) = - IndexView { ixDepth = depth - , ixView = initial - , ixSize = 1 - } -view (Insert e ix) = + if depth > 0 + then pure $ IndexView { ixDepth = depth + , ixView = initial + , ixSize = 1 + } + else Nothing +view (Insert e ix) = do let f = getFunction ix - v = view ix - in v { ixView = f (ixView v) e - , ixSize = min (ixDepth v) (ixSize v + 1) - } -view (Rewind n ix) = - let h = getHistory ix - v = view ix - in v { ixSize = ixSize v - n - , ixView = head $ drop n h - } + v <- view ix + pure $ v { ixView = f (ixView v) e + , ixSize = min (ixDepth v) (ixSize v + 1) + } +view (Rewind n ix) = do + h <- getHistory ix + v <- view ix + if length h > n + then Just $ v { ixSize = ixSize v - n + , ixView = head $ drop n h + } + else Nothing -- | Internal @@ -118,14 +117,18 @@ getFunction (New f _ _) = f getFunction (Insert _ ix) = getFunction ix getFunction (Rewind _ ix) = getFunction ix -getHistory :: Index a e -> [a] -getHistory (New _ _ i) = [i] -getHistory (Insert e ix) = +getHistory :: Index a e -> Maybe [a] +getHistory (New _ _ i) = Just [i] +getHistory (Insert e ix) = do let f = getFunction ix - h = getHistory ix - v = view ix - in f (head h) e : take (ixDepth v - 1) h -getHistory (Rewind n ix) = drop n $ getHistory ix + h <- getHistory ix + v <- view ix + pure $ f (head h) e : take (ixDepth v - 1) h +getHistory (Rewind n ix) = do + h <- getHistory ix + if length h > n + then Just $ drop n h + else Nothing -- | Utility @@ -154,8 +157,8 @@ instance ( CoArbitrary a ] -- Construction can only fail due to NonPositive depth -- Tested with prop_hfNewReturns... - let newHf = fromJust $ new fn depth acc - pure . ObservedBuilder $ insertL bs newHf + let ix = new fn depth acc + pure . ObservedBuilder $ insertL bs ix instance ( CoArbitrary a , CoArbitrary e @@ -177,7 +180,7 @@ instance ( CoArbitrary a ] f <- arbitrary acc <- arbitrary - let ix = fromJust $ new f depth acc + let ix = new f depth acc complexity <- arbitrarySizedIntegral generateGrammarIndex complexity ix @@ -185,9 +188,11 @@ generateGrammarIndex :: Arbitrary e => Int -> Index a e -> Gen (GrammarBuilder a generateGrammarIndex 0 ix = pure $ GrammarBuilder ix generateGrammarIndex n ix = do b <- arbitrary - n <- chooseInt (1, ixDepth $ view ix) + -- This should be correct by construction (the incorrect cases are not very + -- interesting). + n <- chooseInt (1, ixDepth . fromJust $ view ix) nextIx <- frequency [ (80, pure $ insert b ix) - , (20, pure . fromJust $ rewind n ix) + , (20, pure $ rewind n ix) ] generateGrammarIndex (n - 1) nextIx @@ -214,7 +219,7 @@ instance ( Ord a , Arbitrary e , CoArbitrary a , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e) where - observe (IxEvents es) ix = view $ insertL es ix + observe (IxEvents es) ix = fromJust $ view $ insertL es ix ixSignature :: [Sig] ixSignature = @@ -225,10 +230,10 @@ ixSignature = , monoObserve @(Maybe (Index Int Int)) , monoObserve @(Maybe (Index Int [Int])) , mono @(IndexView Int) - , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Maybe (Index Int String)) + , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Index Int String) , con "insert" (insert :: String -> Index Int String -> Index Int String) - , con "view" (view :: Index Int String -> IndexView Int) - , con "rewind" (rewind :: Int -> Index Int String -> Maybe (Index Int String)) - , con "getHistory" (getHistory :: Index Int String -> [Int]) + , con "view" (view :: Index Int String -> Maybe (IndexView Int)) + , con "rewind" (rewind :: Int -> Index Int String -> Index Int String) + , con "getHistory" (getHistory :: Index Int String -> Maybe [Int]) , withMaxTermSize 6 ] diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 5e5faf908c..becd7c7fe6 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -10,9 +10,11 @@ import Data.Functor.Identity (Identity, runIdentity) import Index +import qualified Debug.Trace as Debug + data Conversion m a e = Conversion - { cView :: Index a e -> m (IndexView a) - , cHistory :: Index a e -> m [a] + { cView :: Index a e -> m (Maybe (IndexView a)) + , cHistory :: Index a e -> m (Maybe [a]) , cMonadic :: m Property -> Property } @@ -36,27 +38,28 @@ prop_observeNew c f a = \depth -> cover 30 (depth < 0) "Negative depth" $ cover 30 (depth >= 0) "Non-negative depth" $ - let mix = new (applyFun2 f) depth a - in if depth <= 0 - -- Note: This is not testing construction of the monadic index - then property $ isNothing mix - else monadic (cMonadic c) $ do - let ix = fromJust mix - v <- run $ cView c ix - h <- run $ cHistory c ix - assert $ v == IndexView { ixDepth = depth - , ixView = a - , ixSize = 1 - } - && h == [a] + let ix = new (applyFun2 f) depth a + in monadic (cMonadic c) $ do + if depth <= 0 + then do + mv <- run $ cView c ix + assert $ isNothing mv + else do + v <- run $ cView c ix + h <- run $ cHistory c ix + assert $ v == pure (IndexView { ixDepth = depth + , ixView = a + , ixSize = 1 + }) + && h == Just [a] -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) prop_rewindDepth - :: ObservedBuilder a b + :: Show a => ObservedBuilder a b -> Property prop_rewindDepth (ObservedBuilder ix) = - let v = view ix in + let v = fromJust $ view ix in ixDepth v >= 2 ==> forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) , (30, chooseInt (ixSize v + 1, ixDepth v - 1)) @@ -67,17 +70,17 @@ prop_rewindDepth (ObservedBuilder ix) = "Depth is lower than max but there is not enough data." $ cover 40 (depth <= ixDepth v && depth <= ixSize v) "Depth is properly set." $ - let newIx = rewind depth ix - in if depth > (ixDepth v - 1) || (depth > ixSize v) - then property $ isNothing newIx - else property $ isJust newIx + let mv' = view $ rewind depth ix + in if depth >= ixSize v + then property $ isNothing mv' + else property $ isJust mv' -- | Property that validates the HF data structure. prop_sizeLEDepth :: ObservedBuilder a b -> Property prop_sizeLEDepth (ObservedBuilder ix) = - let v = view ix + let v = fromJust $ view ix in property $ ixSize v <= ixDepth v -- | Relation between Rewind and Inverse @@ -86,7 +89,7 @@ prop_insertRewindInverse => ObservedBuilder a b -> Property prop_insertRewindInverse (ObservedBuilder ix) = - let v = view ix + let v = fromJust $ view ix -- rewind does not make sense for lesser depths. in ixDepth v >= 2 ==> -- if the history is not fully re-written, then we can get a common @@ -94,11 +97,10 @@ prop_insertRewindInverse (ObservedBuilder ix) = -- than `hfDepth hf` forAll (resize (ixDepth v - 1) arbitrary) $ \bs -> - let mix' = rewind (length bs) $ insertL bs ix + let ix' = rewind (length bs) $ insertL bs ix -- This should always be Just.. because of the resize of `bs` - ix' = fromJust mix' - h = take (ixDepth v - length bs) $ getHistory ix - h' = getHistory ix' + h = take (ixDepth v - length bs) $ fromJust $ getHistory ix + h' = fromJust $ getHistory ix' in property $ h == h' -- | Generally this would not be a good property since it is very coupled @@ -110,24 +112,23 @@ prop_observeInsert -> [b] -> Property prop_observeInsert (ObservedBuilder ix) bs = - let v = view ix + let v = fromJust $ view ix in view (insertL bs ix) === - IndexView { ixDepth = ixDepth v - , ixSize = min (ixDepth v) (length bs + ixSize v) - , ixView = foldl' (getFunction ix) (ixView $ view ix) bs - } + Just (IndexView { ixDepth = ixDepth v + , ixSize = min (ixDepth v) (length bs + ixSize v) + , ixView = foldl' (getFunction ix) (ixView v) bs + }) prop_insertSize :: ObservedBuilder a b -> b -> Property prop_insertSize (ObservedBuilder ix) b = - let v = view ix + let v = fromJust $ view ix initialLength = ixSize v - finalLength = ixSize . view $ insert b ix + finalLength = ixSize . fromJust . view $ insert b ix in cover 10 (initialLength == ixDepth v) "Overflowing" $ cover 30 (initialLength < ixDepth v) "Not filled" $ if initialLength == ixDepth v then finalLength === initialLength else finalLength === initialLength + 1 - From 25453f7f4bd9c5f1cf58c961d5b33431b316a948 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 7 Mar 2022 10:56:14 +0700 Subject: [PATCH 34/62] Generalise properties using conversions. --- test/Spec.hs | 12 +++---- test/Spec/Index.hs | 87 ++++++++++++++++++++++++++-------------------- 2 files changed, 54 insertions(+), 45 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 4e81d7a2b2..1a91fcc643 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,8 +8,6 @@ import qualified Index as Ix import qualified Spec.Index as Ix import qualified Index.Split as S -import qualified Debug.Trace as Debug - tests :: TestTree tests = testGroup "Index" [ixProperties] @@ -18,15 +16,15 @@ ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int Ix.conversion , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int Ix.conversion , testProperty "Rewind: Connection with `ixDepth`" $ - withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int Ix.conversion , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int Ix.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int Ix.conversion , testProperty "Insert is increasing the length unless overflowing" $ - withMaxSuccess 10000 $ Ix.prop_insertSize @Int @Int + withMaxSuccess 10000 $ Ix.prop_insertSize @Int @Int Ix.conversion ] diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index becd7c7fe6..10c0d33b3b 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -10,8 +10,6 @@ import Data.Functor.Identity (Identity, runIdentity) import Index -import qualified Debug.Trace as Debug - data Conversion m a e = Conversion { cView :: Index a e -> m (Maybe (IndexView a)) , cHistory :: Index a e -> m (Maybe [a]) @@ -56,9 +54,11 @@ prop_observeNew c f a = -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) prop_rewindDepth - :: Show a => ObservedBuilder a b + :: forall e a m. (Monad m) + => Conversion m a e + -> ObservedBuilder a e -> Property -prop_rewindDepth (ObservedBuilder ix) = +prop_rewindDepth c (ObservedBuilder ix) = let v = fromJust $ view ix in ixDepth v >= 2 ==> forAll (frequency [ (20, chooseInt (ixDepth v, ixDepth v * 2)) @@ -70,25 +70,30 @@ prop_rewindDepth (ObservedBuilder ix) = "Depth is lower than max but there is not enough data." $ cover 40 (depth <= ixDepth v && depth <= ixSize v) "Depth is properly set." $ - let mv' = view $ rewind depth ix - in if depth >= ixSize v - then property $ isNothing mv' - else property $ isJust mv' + monadic (cMonadic c) $ do + mv <- run $ cView c (rewind depth ix) + if depth >= ixSize v + then assert $ isNothing mv + else assert $ isJust mv -- | Property that validates the HF data structure. prop_sizeLEDepth - :: ObservedBuilder a b + :: forall e a m. (Monad m) + => Conversion m a e + -> ObservedBuilder a e -> Property -prop_sizeLEDepth (ObservedBuilder ix) = - let v = fromJust $ view ix - in property $ ixSize v <= ixDepth v +prop_sizeLEDepth c (ObservedBuilder ix) = + monadic (cMonadic c) $ do + (Just v) <- run $ cView c ix + assert $ ixSize v <= ixDepth v -- | Relation between Rewind and Inverse prop_insertRewindInverse - :: (Show a, Show b, Arbitrary b, Eq a) - => ObservedBuilder a b + :: forall e a m. (Monad m, Show e, Arbitrary e, Eq a) + => Conversion m a e + -> ObservedBuilder a e -> Property -prop_insertRewindInverse (ObservedBuilder ix) = +prop_insertRewindInverse c (ObservedBuilder ix) = let v = fromJust $ view ix -- rewind does not make sense for lesser depths. in ixDepth v >= 2 ==> @@ -96,39 +101,45 @@ prop_insertRewindInverse (ObservedBuilder ix) = -- prefix after the insert/rewind play. We need input which is less -- than `hfDepth hf` forAll (resize (ixDepth v - 1) arbitrary) $ - \bs -> - let ix' = rewind (length bs) $ insertL bs ix - -- This should always be Just.. because of the resize of `bs` - h = take (ixDepth v - length bs) $ fromJust $ getHistory ix - h' = fromJust $ getHistory ix' - in property $ h == h' + \bs -> monadic (cMonadic c) $ do + let ix' = rewind (length bs) $ insertL bs ix + Just v' <- run $ cView c ix + h <- take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) + h' <- fromJust <$> run (cHistory c ix') + assert $ h == h' -- | Generally this would not be a good property since it is very coupled -- to the implementation, but it will be useful when trying to certify that -- another implmentation is confirming. prop_observeInsert - :: (Eq a, Show a) - => ObservedBuilder a b - -> [b] + :: forall e a m. (Monad m, Eq a, Show a) + => Conversion m a e + -> ObservedBuilder a e + -> [e] -> Property -prop_observeInsert (ObservedBuilder ix) bs = - let v = fromJust $ view ix - in view (insertL bs ix) === - Just (IndexView { ixDepth = ixDepth v - , ixSize = min (ixDepth v) (length bs + ixSize v) - , ixView = foldl' (getFunction ix) (ixView v) bs - }) +prop_observeInsert c (ObservedBuilder ix) bs = + monadic (cMonadic c) $ do + Just v <- run $ cView c ix + let ix' = insertL bs ix + Just v' <- run $ cView c ix' + assert $ v' == IndexView { ixDepth = ixDepth v + , ixSize = min (ixDepth v) (length bs + ixSize v) + , ixView = foldl' (getFunction ix) (ixView v) bs + } prop_insertSize - :: ObservedBuilder a b - -> b + :: forall e a m. Monad m + => Conversion m a e + -> ObservedBuilder a e + -> e -> Property -prop_insertSize (ObservedBuilder ix) b = +prop_insertSize c (ObservedBuilder ix) b = let v = fromJust $ view ix initialLength = ixSize v - finalLength = ixSize . fromJust . view $ insert b ix in cover 10 (initialLength == ixDepth v) "Overflowing" $ cover 30 (initialLength < ixDepth v) "Not filled" $ - if initialLength == ixDepth v - then finalLength === initialLength - else finalLength === initialLength + 1 + monadic (cMonadic c) $ do + finalLength <- ixSize . fromJust <$> run (cView c $ insert b ix) + if initialLength == ixDepth v + then assert $ finalLength == initialLength + else assert $ finalLength == initialLength + 1 From b355f6afdbc69eb1eea375fb4f4b8201145322a3 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 7 Mar 2022 11:04:33 +0700 Subject: [PATCH 35/62] Test scenario covered by previous test. --- test/Spec.hs | 2 -- test/Spec/Index.hs | 17 ----------------- 2 files changed, 19 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 1a91fcc643..2b7e4c13b7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -23,8 +23,6 @@ ixProperties = testGroup "Basic model" withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int Ix.conversion , testProperty "Insert is folding the structure" $ withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int Ix.conversion - , testProperty "Insert is increasing the length unless overflowing" $ - withMaxSuccess 10000 $ Ix.prop_insertSize @Int @Int Ix.conversion ] diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 10c0d33b3b..ae77817dfb 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -126,20 +126,3 @@ prop_observeInsert c (ObservedBuilder ix) bs = , ixSize = min (ixDepth v) (length bs + ixSize v) , ixView = foldl' (getFunction ix) (ixView v) bs } - -prop_insertSize - :: forall e a m. Monad m - => Conversion m a e - -> ObservedBuilder a e - -> e - -> Property -prop_insertSize c (ObservedBuilder ix) b = - let v = fromJust $ view ix - initialLength = ixSize v - in cover 10 (initialLength == ixDepth v) "Overflowing" $ - cover 30 (initialLength < ixDepth v) "Not filled" $ - monadic (cMonadic c) $ do - finalLength <- ixSize . fromJust <$> run (cView c $ insert b ix) - if initialLength == ixDepth v - then assert $ finalLength == initialLength - else assert $ finalLength == initialLength + 1 From 19abbb5e7319ee1a3784e1d2936abcc49ae46e98 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 7 Mar 2022 12:59:24 +0700 Subject: [PATCH 36/62] Cleanup --- hysterical-screams.cabal | 3 ++- package.yaml | 3 +++ src/Index.hs | 14 +++++++------- src/Index/Split.hs | 16 ++-------------- test/Spec.hs | 1 - test/Spec/Index.hs | 1 - 6 files changed, 14 insertions(+), 24 deletions(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 674f569aec..37a04ff96b 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -44,6 +44,7 @@ library MultiParamTypeClasses FlexibleInstances GADTs + ghc-options: -Wall build-depends: QuickCheck , base >=4.7 && <5 @@ -68,7 +69,7 @@ test-suite hysterical-screams-test MultiParamTypeClasses FlexibleInstances GADTs - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck , base >=4.7 && <5 diff --git a/package.yaml b/package.yaml index 9e0c81037f..655a57798f 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,8 @@ dependencies: library: source-dirs: src + ghc-options: + - -Wall verbatim: Tested-With: GHC ==8.10.7 @@ -51,6 +53,7 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N + - -Wall dependencies: - hysterical-screams - QuickCheck diff --git a/src/Index.hs b/src/Index.hs index fab74d0eb6..945ea642ec 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -21,7 +21,7 @@ import Control.Monad (replicateM) import Data.Foldable (foldl') import Data.Maybe (fromJust) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, - arbitrarySizedIntegral, choose, chooseInt, + arbitrarySizedIntegral, chooseInt, frequency, listOf, sized) import QuickSpec import GHC.Generics @@ -58,7 +58,7 @@ data Index a e = New (a -> e -> a) Int a | Rewind Int (Index a e) instance (Show a, Show e) => Show (Index a e) where - show (New f depth acc) = "New " <> show depth <> " " <> show acc + show (New _ depth acc) = "New " <> show depth <> " " <> show acc show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" @@ -88,7 +88,7 @@ rewind = Rewind -- | Observations view :: Index a e -> Maybe (IndexView a) -view (New f depth initial) = +view (New _ depth initial) = if depth > 0 then pure $ IndexView { ixDepth = depth , ixView = initial @@ -190,9 +190,9 @@ generateGrammarIndex n ix = do b <- arbitrary -- This should be correct by construction (the incorrect cases are not very -- interesting). - n <- chooseInt (1, ixDepth . fromJust $ view ix) + d <- chooseInt (1, ixDepth . fromJust $ view ix) nextIx <- frequency [ (80, pure $ insert b ix) - , (20, pure $ rewind n ix) + , (20, pure $ rewind d ix) ] generateGrammarIndex (n - 1) nextIx @@ -200,10 +200,10 @@ instance Arbitrary a => Arbitrary (IndexView a) where arbitrary = sized $ \n -> do depth <- chooseInt (2, n) size <- chooseInt (0, depth) - view <- arbitrary + view' <- arbitrary pure IndexView { ixDepth = depth , ixSize = size - , ixView = view + , ixView = view' } -- | QuickSpec diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 5353d4529c..70787d4e55 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -11,12 +11,9 @@ module Index.Split , rewind ) where -import Control.Monad ((=<<)) -import Data.Foldable (foldl', foldlM) -import Data.Maybe (fromJust) +import Data.Foldable (foldlM) -import Index (Index (..), IndexView (..)) -import qualified Index as Ix +import Index (IndexView (..)) data SplitIndex m a e = SplitIndex { siHandle :: m a @@ -82,12 +79,3 @@ toIndexView si@SplitIndex{siHandle, siDepth, siStore, siEvents} = do , ixView = v } -fromIndex :: forall m a e. Monad m => Index a e -> m (SplitIndex m a e) -fromIndex (Ix.New f depth acc) = - pure $ fromJust $ new merge depth (pure acc) - where - merge :: Monad m => a -> [e] -> m a - merge acc es = pure $ foldl' f acc es -fromIndex (Ix.Insert e ix) = insert e =<< fromIndex ix -fromIndex (Ix.Rewind n ix) = rewind n <$> fromIndex ix - diff --git a/test/Spec.hs b/test/Spec.hs index 2b7e4c13b7..82dd41a5f0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,3 @@ -import Data.Maybe (fromJust, isJust, isNothing) import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index ae77817dfb..04448725ee 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -1,7 +1,6 @@ module Spec.Index where import QuickSpec -import Test.Tasty import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic import Data.Maybe (fromJust, isJust, isNothing) From 62065c04c74c7d88d67374dddd1164828e6513d8 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 8 Mar 2022 07:45:39 +0700 Subject: [PATCH 37/62] Testing infrastructure for SplitIndex. --- hysterical-screams.cabal | 3 ++ package.yaml | 1 + src/Index/Split.hs | 78 ++++++++++++++++++++++++---------------- test/Spec/Split.hs | 70 ++++++++++++++++++++++++++++++++++++ 4 files changed, 122 insertions(+), 30 deletions(-) create mode 100644 test/Spec/Split.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 37a04ff96b..3906fad9d3 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -41,6 +41,7 @@ library TypeApplications PatternSynonyms DeriveGeneric + NamedFieldPuns MultiParamTypeClasses FlexibleInstances GADTs @@ -56,6 +57,7 @@ test-suite hysterical-screams-test main-is: Spec.hs other-modules: Spec.Index + Spec.Split Paths_hysterical_screams hs-source-dirs: test @@ -66,6 +68,7 @@ test-suite hysterical-screams-test TypeApplications PatternSynonyms DeriveGeneric + NamedFieldPuns MultiParamTypeClasses FlexibleInstances GADTs diff --git a/package.yaml b/package.yaml index 655a57798f..9cdf4f4bbf 100644 --- a/package.yaml +++ b/package.yaml @@ -28,6 +28,7 @@ default-extensions: - TypeApplications - PatternSynonyms - DeriveGeneric + - NamedFieldPuns - MultiParamTypeClasses - FlexibleInstances - GADTs diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 70787d4e55..4726b5fcbe 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -3,23 +3,31 @@ module Index.Split ( -- * API - SplitIndex + SplitIndex(..) , new , insert , insertL , size , rewind + -- * Observations + , view + , getHistory + , getEvents ) where import Data.Foldable (foldlM) +import Data.List (scanl') import Index (IndexView (..)) data SplitIndex m a e = SplitIndex - { siHandle :: m a - , siEvents :: [e] - , siDepth :: Int - , siStore :: a -> [e] -> m a + { siStoredIx :: m a + -- ^ Combined view of `[e]` and `m a` + , siEvents :: [e] + , siDepth :: Int + , siStore :: a -> m a + , siIndex :: a -> [e] -> a + -- ^ Not sure how reasonble this is for a SQL db, but will leave it as-is for now } storeEventsThreshold :: Int @@ -27,17 +35,19 @@ storeEventsThreshold = 3 new :: Monad m - => (a -> [e] -> m a) + => (a -> [e] -> a) + -> (a -> m a) -> Int -> m a -> Maybe (SplitIndex m a e) -new store depth acc - | depth <= 0 = Nothing - | otherwise = Just $ SplitIndex - { siHandle = acc - , siEvents = [] - , siDepth = depth - , siStore = store +new findex fstore depth ix + | depth <= 0 = Nothing + | otherwise = Just $ SplitIndex + { siStoredIx = ix + , siEvents = [] + , siDepth = depth + , siStore = fstore + , siIndex = findex } insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) @@ -48,12 +58,13 @@ insert e ix@SplitIndex{ siEvents, siDepth } = do pure ix' { siEvents = e : siEvents } mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) -mergeEvents ix@SplitIndex { siEvents, siDepth, siStore, siHandle } = do +mergeEvents ix@SplitIndex { siEvents, siDepth, siStore, siIndex, siStoredIx } = do let liveEs = take siDepth siEvents storedEs = drop siDepth siEvents - h <- siHandle - nextStore <- siStore h storedEs - pure $ ix { siHandle = pure nextStore + six <- siStoredIx + let six' = siIndex six storedEs + nextStore <- siStore six' + pure $ ix { siStoredIx = pure nextStore , siEvents = liveEs } @@ -62,20 +73,27 @@ insertL es ix = foldlM (flip insert) ix es size :: SplitIndex m a e -> Int size SplitIndex { siDepth, siEvents } = - min siDepth (length siEvents) + min siDepth (length siEvents + 1) -rewind :: Int -> SplitIndex m a e -> SplitIndex m a e -rewind n ix@SplitIndex { siEvents } = - ix { siEvents = drop n siEvents } +rewind :: Int -> SplitIndex m a e -> Maybe (SplitIndex m a e) +rewind n ix@SplitIndex { siEvents } + | length siEvents > n = Just $ ix { siEvents = drop n siEvents } + | otherwise = Nothing --- | Using Split as an interpretation of Index - -toIndexView :: Monad m => SplitIndex m a e -> m (IndexView a) -toIndexView si@SplitIndex{siHandle, siDepth, siStore, siEvents} = do - h <- siHandle - v <- siStore h siEvents - pure $ IndexView { ixDepth = siDepth - , ixSize = size si - , ixView = v +view :: Monad m => SplitIndex m a e -> m (IndexView a) +view SplitIndex{siStoredIx, siDepth, siEvents, siIndex} = do + v <- siStoredIx + let d = siDepth + s = length siEvents + 1 + pure $ IndexView { ixDepth = d + , ixView = siIndex v siEvents + , ixSize = s } +getHistory :: Monad m => SplitIndex m a e -> m [a] +getHistory SplitIndex{siStoredIx, siIndex, siEvents} = do + storedIx <- siStoredIx + pure $ scanl' (\a e -> siIndex a [e]) storedIx siEvents + +getEvents :: SplitIndex m a e -> [e] +getEvents SplitIndex{siEvents} = siEvents diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs new file mode 100644 index 0000000000..1cd6f2cfa2 --- /dev/null +++ b/test/Spec/Split.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Spec.Split where + +import Control.Monad ((>=>)) +import Data.Foldable (foldl') +import Data.Functor ((<&>)) +import Test.QuickCheck (Property) +import Test.QuickCheck.Monadic (PropertyM, monadicIO) + +import Index (Index, IndexView (..)) +import qualified Index as Ix +import Index.Split (SplitIndex (..)) +import qualified Index.Split as S +import Spec.Index (Conversion (..)) + +conversion :: Conversion (PropertyM IO) a e +conversion = Conversion + { cView = view + , cHistory = history + , cMonadic = monadic + } + +view + :: Index a e + -> PropertyM IO (Maybe (IndexView a)) +view ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> do + v <- S.view ix' + pure $ Just v + +history + :: Index a e + -> PropertyM IO (Maybe [a]) +history ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> do + h <- S.getHistory ix' + pure $ Just h + +monadic + :: PropertyM IO Property + -> Property +monadic = monadicIO + +run + :: forall m a e. Monad m + => Index a e + -> m (Maybe (SplitIndex m a e)) +run (Ix.New f d a) = pure $ S.new findex fstore d (pure a) + where + findex :: a -> [e] -> a + findex a' es = foldl' f a' es + fstore :: a -> m a + fstore a' = pure a' +run (Ix.Insert e ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> Just <$> S.insert e ix' +run (Ix.Rewind n ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> pure $ S.rewind n ix' From 734175351f382c815a39c2247e84c4ee33c3b897 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 8 Mar 2022 14:06:25 +0700 Subject: [PATCH 38/62] Add a README --- README.md | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/README.md b/README.md index 173a0df221..da7fe635e3 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,62 @@ # historical-streams [![Haskell-CI](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml) + +# A study of algebraic specification. + +## Define a simplified model. + +We want to define an indexing data structure that has the capacity of maintaining a current state (viewed as a fold over a stream of events) and which can rewind to a previous value in case a rollback happens on the stream. We only store K (we call it depth) versions of the previous accumulator (since we know that we will only rollback at most K blocks). + +The model is split between constructors and observations. You can identify the constructors with a grammar that generates a program in your algebra and observations define the semantics of this defined language. + +Example of a program in this algebra: `rewind 1 $ insert 1 $ new (+) 5`. We can think as the value of the accumulator at the end of running this program as an observation which has value `5`. + +I our case we have three constructors: +* new => creates a new index, and takes as arguments a function used to fold events into an accumulator and an initial value for the accumulator. +* insert => adds a new event into the index +* rewind => returns the data structure to a previous version. + +.. and 3 observations: +* view: + * depth - how many versions do we remember + * size - how many versions do we currently store. + * accumulator value - what is the current value of the accumulator. +* history (the historical accumulator values) +* function (looks up the function used for folding) + +One of the mistakes I made initially was to include the possiblity of failing when building syntax (new and review could return `Nothing`). In retrospect this was a bad decision because it would not allow me to test the negative of the property for other data types. I removed all possibilities of errors from the constructors and moved them to the observations. + +On this model we identify some properties by specifying how our observations are influenced by the chaining of constructors. + +1) *observeNew* talks about what we can observe from viewing or getting the history after a call to `new`. If the depth is negative then all observations should return `Nothing`. + +2) *rewindDepth* checks that observations of rewind are only valid when the number of events we want to undo is lower than what we have stored (and by proxy is lower than the maximum depth of the data structure). + +3) *rewindInverse* captures that intuition that (under very specific conditions) insert and rewind behave a bit like inverses. + +4) *observeInsert* captures the way insert changes observations. This is one of the gripes I've had with testing for a while when you write tests that duplicate the code used to implement the functions you are testing. However, in this case it makes sense, since this property is not used to check our model as much as check other, more complex data structures that we check for conformity with the model. + +5) *sizeLEDepth* this is an invariant for the data structure. Size should always be less than the maximum size. I am not sure I want to keep this property. It does not seem very useful, but it's an example of an invariant. + +## Define a more complex data type + +I define a more efficient data type based on the observation that part of the chain is immutable and the part that is immutable could be stored fully on disk. Then we would only use RAM to store the changes that happened in the mutable part of the blockchain. + +The structure is a bit more complex in order to support batching events to be persisted more efficiently. + +The way I implemented the verification that this data structure is compliant with the properties identified for the model previously defined is by generalising the properties themselves by providing functions that convert between model programs and observations of the complex data structures. + +To test the properties for the initial model we use the `Identity` monad and the view conversion functions are the ones defined by the `Index` module. + +For the complex data structure the flow is as follow: given an Index program that has one pure observation derived from the model, it must match the complex observation of the data structure. + +## Lessons learned + +* The first implementation of the simplified model was not algebraic and it was awkward to think of a more complex data structure as a interpretation of a language. So, when defining a model, thinking in terms of constructors and observations seems very important. Then what we get is something equivalent to a free algebra (hence algebraic specification). +* The process of developing things in this manner is fairly slow and tenuous, but it does force one to contemplate the design choices that were made and think deeply about the meaning of the used data structures (do we need to expose a size or a depth in our views? why? what happens if we do not do that?). +* The process *is* an interative one, where the model changes informed by requirements from the software, and the software changes to satisfy the properties required by the model. Both the model and the implementation have changed several times, and they will probably keep on changing (test don't pass yet for the complex data structure). +* Thinking about these problems has given me a lot more insight into the problem that we are trying to solve and I could identify easily shortcomings, inefficiencies or unwaranted complexity of other approaches. +* The amount of bugs that only 5 properties can detect is impresive. Not all of those were actual reasoning failings, but some were (a couple of bugs were off-by-one errors). +* The amount of bugs that can fit into a more complex than the model, but not really that complex data structure is also quite impressive. +* Finding the cause of property violations is not very fun, but not incredibly annoying either. I think there are improvements to be made in this area. From 73e3e16d79d296f4ddfb1f43707f7300e4e0543e Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 8 Mar 2022 14:32:40 +0700 Subject: [PATCH 39/62] Fix some bugs. --- src/Index/Split.hs | 45 ++++++++++++++++++++++++++------------------- test/Spec.hs | 20 +++++++++++++++----- test/Spec/Index.hs | 4 +++- test/Spec/Split.hs | 2 -- 4 files changed, 44 insertions(+), 27 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 4726b5fcbe..6a1ba2f77d 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -24,6 +24,7 @@ data SplitIndex m a e = SplitIndex { siStoredIx :: m a -- ^ Combined view of `[e]` and `m a` , siEvents :: [e] + , siBuffered :: [e] , siDepth :: Int , siStore :: a -> m a , siIndex :: a -> [e] -> a @@ -45,55 +46,61 @@ new findex fstore depth ix | otherwise = Just $ SplitIndex { siStoredIx = ix , siEvents = [] + , siBuffered = [] , siDepth = depth , siStore = fstore , siIndex = findex } insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) -insert e ix@SplitIndex{ siEvents, siDepth } = do - ix' <- if length siEvents > siDepth * storeEventsThreshold +insert e ix@SplitIndex{siEvents, siDepth, siBuffered} = do + ix' <- if length siBuffered > siDepth * storeEventsThreshold then mergeEvents ix else pure ix - pure ix' { siEvents = e : siEvents } + let (siEvents', siBuffered') + = if length siEvents == siDepth + then ( e : take (siDepth - 1) siEvents + , last siEvents : siBuffered ) + else ( e : siEvents, siBuffered ) + pure ix' { siEvents = siEvents' + , siBuffered = siBuffered' + } mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) -mergeEvents ix@SplitIndex { siEvents, siDepth, siStore, siIndex, siStoredIx } = do - let liveEs = take siDepth siEvents - storedEs = drop siDepth siEvents +mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do six <- siStoredIx - let six' = siIndex six storedEs + let six' = siIndex six siBuffered nextStore <- siStore six' pure $ ix { siStoredIx = pure nextStore - , siEvents = liveEs + , siBuffered = [] } insertL :: Monad m => [e] -> SplitIndex m a e -> m (SplitIndex m a e) insertL es ix = foldlM (flip insert) ix es +-- TODO: Do we actually need size < depth? size :: SplitIndex m a e -> Int -size SplitIndex { siDepth, siEvents } = - min siDepth (length siEvents + 1) +size SplitIndex {siEvents} = + length siEvents + 1 rewind :: Int -> SplitIndex m a e -> Maybe (SplitIndex m a e) -rewind n ix@SplitIndex { siEvents } - | length siEvents > n = Just $ ix { siEvents = drop n siEvents } +rewind n ix@SplitIndex {siEvents} + | size ix > n = Just $ ix { siEvents = drop n siEvents } | otherwise = Nothing view :: Monad m => SplitIndex m a e -> m (IndexView a) -view SplitIndex{siStoredIx, siDepth, siEvents, siIndex} = do +view ix@SplitIndex{siStoredIx, siDepth, siEvents, siIndex} = do v <- siStoredIx - let d = siDepth - s = length siEvents + 1 - pure $ IndexView { ixDepth = d + pure $ IndexView { ixDepth = siDepth , ixView = siIndex v siEvents - , ixSize = s + , ixSize = size ix } getHistory :: Monad m => SplitIndex m a e -> m [a] -getHistory SplitIndex{siStoredIx, siIndex, siEvents} = do +getHistory SplitIndex{siDepth, siStoredIx, siIndex, siEvents} = do storedIx <- siStoredIx - pure $ scanl' (\a e -> siIndex a [e]) storedIx siEvents + let es = scanl' (\a e -> siIndex a [e]) storedIx siEvents + pure $ take (min (siDepth + 1) (length es)) es getEvents :: SplitIndex m a e -> [e] getEvents SplitIndex{siEvents} = siEvents diff --git a/test/Spec.hs b/test/Spec.hs index 82dd41a5f0..8c45285197 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,8 @@ -import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck -import Index (Index, IndexView (..)) -import qualified Index as Ix -import qualified Spec.Index as Ix -import qualified Index.Split as S +import qualified Spec.Index as Ix +import qualified Spec.Split as S tests :: TestTree tests = testGroup "Index" [ixProperties] @@ -24,6 +21,19 @@ ixProperties = testGroup "Basic model" withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int Ix.conversion ] +siProperties :: TestTree +siProperties = testGroup "Split index" + [ testProperty "New: Positive or non-positive depth" $ + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int S.conversion + , testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion + , testProperty "Rewind: Connection with `ixDepth`" $ + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int S.conversion + , testProperty "Relationship between Insert/Rewind" $ + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int S.conversion + , testProperty "Insert is folding the structure" $ + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion + ] main :: IO () main = do diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 04448725ee..200641dcab 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -9,6 +9,8 @@ import Data.Functor.Identity (Identity, runIdentity) import Index +import qualified Debug.Trace as Debug + data Conversion m a e = Conversion { cView :: Index a e -> m (Maybe (IndexView a)) , cHistory :: Index a e -> m (Maybe [a]) @@ -88,7 +90,7 @@ prop_sizeLEDepth c (ObservedBuilder ix) = -- | Relation between Rewind and Inverse prop_insertRewindInverse - :: forall e a m. (Monad m, Show e, Arbitrary e, Eq a) + :: forall e a m. (Monad m, Show e, Show a, Arbitrary e, Eq a) => Conversion m a e -> ObservedBuilder a e -> Property diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 1cd6f2cfa2..94fb1b4236 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -2,9 +2,7 @@ module Spec.Split where -import Control.Monad ((>=>)) import Data.Foldable (foldl') -import Data.Functor ((<&>)) import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) From 8a1af0ee7d5414d4cd32a85fc7018cc9de32e8bb Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 8 Mar 2022 20:54:37 +0700 Subject: [PATCH 40/62] Fixed depth property tests. --- src/Index/Split.hs | 31 +++++++++++++++++++------------ test/Spec.hs | 10 +++++----- 2 files changed, 24 insertions(+), 17 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 6a1ba2f77d..b62fd5af68 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -53,18 +53,25 @@ new findex fstore depth ix } insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) -insert e ix@SplitIndex{siEvents, siDepth, siBuffered} = do - ix' <- if length siBuffered > siDepth * storeEventsThreshold - then mergeEvents ix - else pure ix - let (siEvents', siBuffered') - = if length siEvents == siDepth - then ( e : take (siDepth - 1) siEvents - , last siEvents : siBuffered ) - else ( e : siEvents, siBuffered ) - pure ix' { siEvents = siEvents' - , siBuffered = siBuffered' - } +insert e ix@SplitIndex{siEvents, siDepth, siBuffered} + | siDepth /= 1 = do + let (siEvents', siBuffered') + = if length siEvents == siDepth - 1 + then ( e : take (siDepth - 2) siEvents + , last siEvents : siBuffered ) + else ( e : siEvents, siBuffered ) + ix' <- if length siBuffered > siDepth * storeEventsThreshold + then mergeEvents ix + else pure ix + pure ix' { siEvents = siEvents' + , siBuffered = siBuffered' + } + -- Special casing siDepth == 1 => siEvents is unused. + | otherwise = do + let siBuffered' = e : siBuffered + if length siBuffered' > siDepth * storeEventsThreshold + then mergeEvents ix + else pure ix mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do diff --git a/test/Spec.hs b/test/Spec.hs index 8c45285197..c1b18db783 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,7 @@ import qualified Spec.Index as Ix import qualified Spec.Split as S tests :: TestTree -tests = testGroup "Index" [ixProperties] +tests = testGroup "Index" [siProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" @@ -23,16 +23,16 @@ ixProperties = testGroup "Basic model" siProperties :: TestTree siProperties = testGroup "Split index" - [ testProperty "New: Positive or non-positive depth" $ + [ {-testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int S.conversion - , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion + , -}testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion {- , testProperty "Rewind: Connection with `ixDepth`" $ withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int S.conversion , testProperty "Relationship between Insert/Rewind" $ withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int S.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion -} ] main :: IO () From 2c4bbdd2496fa1ff1b59ed1e001e8899650c7b62 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 15 Mar 2022 07:32:04 +0700 Subject: [PATCH 41/62] Property based tests pass. --- src/Index.hs | 16 +++++++++------- src/Index/Split.hs | 47 ++++++++++++++++++++++++++-------------------- test/Spec.hs | 10 +++++----- test/Spec/Index.hs | 20 ++++++++++++++------ test/Spec/Split.hs | 40 ++++++++++++++++++++++++++++----------- 5 files changed, 84 insertions(+), 49 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 945ea642ec..b21d240405 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -20,11 +20,11 @@ module Index import Control.Monad (replicateM) import Data.Foldable (foldl') import Data.Maybe (fromJust) +import GHC.Generics +import QuickSpec import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, - arbitrarySizedIntegral, chooseInt, - frequency, listOf, sized) -import QuickSpec -import GHC.Generics + arbitrarySizedIntegral, chooseInt, frequency, + listOf, shrinkNothing, sized) {- | Laws Constructors: new, insert, rewind @@ -59,8 +59,8 @@ data Index a e = New (a -> e -> a) Int a instance (Show a, Show e) => Show (Index a e) where show (New _ depth acc) = "New " <> show depth <> " " <> show acc - show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" - show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" + show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" + show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" newtype GrammarBuilder a e = GrammarBuilder (Index a e) deriving (Show) @@ -134,6 +134,7 @@ getHistory (Rewind n ix) = do insertL :: [e] -> Index a e -> Index a e insertL es ix = foldl' (flip insert) ix es + -- | QuickCheck instance ( CoArbitrary a @@ -158,7 +159,7 @@ instance ( CoArbitrary a -- Construction can only fail due to NonPositive depth -- Tested with prop_hfNewReturns... let ix = new fn depth acc - pure . ObservedBuilder $ insertL bs ix + pure . ObservedBuilder $ insertL bs ix instance ( CoArbitrary a , CoArbitrary e @@ -168,6 +169,7 @@ instance ( CoArbitrary a arbitrary = do (ObservedBuilder ix) <- arbitrary pure ix + shrink = shrinkNothing instance ( CoArbitrary a , CoArbitrary e diff --git a/src/Index/Split.hs b/src/Index/Split.hs index b62fd5af68..f559c20f8e 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} - module Index.Split ( -- * API SplitIndex(..) @@ -20,6 +17,8 @@ import Data.List (scanl') import Index (IndexView (..)) +import qualified Debug.Trace as Debug + data SplitIndex m a e = SplitIndex { siStoredIx :: m a -- ^ Combined view of `[e]` and `m a` @@ -31,6 +30,10 @@ data SplitIndex m a e = SplitIndex -- ^ Not sure how reasonble this is for a SQL db, but will leave it as-is for now } +instance (Show a, Show e) => Show (SplitIndex m a e) where + show SplitIndex{siEvents, siBuffered, siStoredIx} = + "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" + storeEventsThreshold :: Int storeEventsThreshold = 3 @@ -56,22 +59,23 @@ insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) insert e ix@SplitIndex{siEvents, siDepth, siBuffered} | siDepth /= 1 = do let (siEvents', siBuffered') - = if length siEvents == siDepth - 1 + = if size ix == siDepth then ( e : take (siDepth - 2) siEvents , last siEvents : siBuffered ) else ( e : siEvents, siBuffered ) - ix' <- if length siBuffered > siDepth * storeEventsThreshold - then mergeEvents ix - else pure ix - pure ix' { siEvents = siEvents' - , siBuffered = siBuffered' - } + let ix' = ix { siEvents = siEvents' + , siBuffered = siBuffered' + } + if length siBuffered' > siDepth * storeEventsThreshold + then mergeEvents ix' + else pure ix' -- Special casing siDepth == 1 => siEvents is unused. | otherwise = do let siBuffered' = e : siBuffered + let ix' = ix { siBuffered = e : siBuffered } if length siBuffered' > siDepth * storeEventsThreshold - then mergeEvents ix - else pure ix + then mergeEvents ix' + else pure ix' mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do @@ -93,21 +97,24 @@ size SplitIndex {siEvents} = rewind :: Int -> SplitIndex m a e -> Maybe (SplitIndex m a e) rewind n ix@SplitIndex {siEvents} | size ix > n = Just $ ix { siEvents = drop n siEvents } - | otherwise = Nothing + | otherwise = {-Debug.trace ("{ returing nothing from rewind " <> show (size ix) <> " " <> show n <> " }") -} Nothing view :: Monad m => SplitIndex m a e -> m (IndexView a) -view ix@SplitIndex{siStoredIx, siDepth, siEvents, siIndex} = do - v <- siStoredIx +view ix@SplitIndex{siDepth} = do + h <- getHistory ix pure $ IndexView { ixDepth = siDepth - , ixView = siIndex v siEvents + , ixView = head h , ixSize = size ix } -getHistory :: Monad m => SplitIndex m a e -> m [a] -getHistory SplitIndex{siDepth, siStoredIx, siIndex, siEvents} = do +getHistory :: forall m e a. Monad m => SplitIndex m a e -> m [a] +getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do storedIx <- siStoredIx - let es = scanl' (\a e -> siIndex a [e]) storedIx siEvents - pure $ take (min (siDepth + 1) (length es)) es + let a = foldr index storedIx siBuffered + pure $ scanr index a siEvents + where + index :: e -> a -> a + index e a = siIndex a [e] getEvents :: SplitIndex m a e -> [e] getEvents SplitIndex{siEvents} = siEvents diff --git a/test/Spec.hs b/test/Spec.hs index c1b18db783..3ed85962e7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,7 @@ import qualified Spec.Index as Ix import qualified Spec.Split as S tests :: TestTree -tests = testGroup "Index" [siProperties] +tests = testGroup "Index" [ixProperties, siProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" @@ -23,16 +23,16 @@ ixProperties = testGroup "Basic model" siProperties :: TestTree siProperties = testGroup "Split index" - [ {-testProperty "New: Positive or non-positive depth" $ + [ testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int S.conversion - , -}testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion {- + , testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion , testProperty "Rewind: Connection with `ixDepth`" $ withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int S.conversion , testProperty "Relationship between Insert/Rewind" $ withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int S.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion -} + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion ] main :: IO () diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 200641dcab..3c170ec57b 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -107,6 +107,7 @@ prop_insertRewindInverse c (ObservedBuilder ix) = Just v' <- run $ cView c ix h <- take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) h' <- fromJust <$> run (cHistory c ix') + -- assert $ Debug.trace ("h = " <> show h <> ", h' = " <> show h' <> " bs = " <> show bs <> " ix: " <> show ix <> " ix': " <> show ix') $ h == h' assert $ h == h' -- | Generally this would not be a good property since it is very coupled @@ -118,12 +119,19 @@ prop_observeInsert -> ObservedBuilder a e -> [e] -> Property -prop_observeInsert c (ObservedBuilder ix) bs = +prop_observeInsert c (ObservedBuilder ix) es = monadic (cMonadic c) $ do Just v <- run $ cView c ix - let ix' = insertL bs ix + let ix' = insertL es ix Just v' <- run $ cView c ix' - assert $ v' == IndexView { ixDepth = ixDepth v - , ixSize = min (ixDepth v) (length bs + ixSize v) - , ixView = foldl' (getFunction ix) (ixView v) bs - } + h <- run $ cHistory c ix' + let v'' = IndexView { ixDepth = ixDepth v + , ixSize = min (ixDepth v) (length es + ixSize v) + , ixView = foldl' (getFunction ix) (ixView v) es + } + -- assert $ v' == IndexView { ixDepth = ixDepth v + -- , ixSize = min (ixDepth v) (length bs + ixSize v) + -- , ixView = foldl' (getFunction ix) (ixView v) bs + -- } + -- assert $ Debug.trace ("History: " <> show h) True + assert $ {-Debug.trace ("v' = " <> show v' <> " v'' = " <> show v'') $-} v' == v'' diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 94fb1b4236..2fb4a53ce3 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -12,7 +12,9 @@ import Index.Split (SplitIndex (..)) import qualified Index.Split as S import Spec.Index (Conversion (..)) -conversion :: Conversion (PropertyM IO) a e +import qualified Debug.Trace as Debug + +conversion :: (Show a, Show e) => Conversion (PropertyM IO) a e conversion = Conversion { cView = view , cHistory = history @@ -20,7 +22,8 @@ conversion = Conversion } view - :: Index a e + :: (Show a, Show e) + => Index a e -> PropertyM IO (Maybe (IndexView a)) view ix = do mix <- run ix @@ -31,13 +34,16 @@ view ix = do pure $ Just v history - :: Index a e + :: (Show a, Show e) + => Index a e -> PropertyM IO (Maybe [a]) history ix = do mix <- run ix case mix of Nothing -> pure Nothing Just ix' -> do + h' <- S.getHistory ix' + -- h <- Debug.trace ("Getting history of " <> show ix' <> " as " <> show h') $ S.getHistory ix' h <- S.getHistory ix' pure $ Just h @@ -47,22 +53,34 @@ monadic monadic = monadicIO run - :: forall m a e. Monad m + :: forall m a e. (Show a, Show e, Monad m) => Index a e -> m (Maybe (SplitIndex m a e)) -run (Ix.New f d a) = pure $ S.new findex fstore d (pure a) +run ix@(Ix.New f d a) = + let nix = S.new findex fstore d (pure a) + -- in Debug.trace ("\n Result of interpreting " <> show ix <> " => " <> show nix <> "\n") $ pure $ S.new findex fstore d (pure a) + in pure $ S.new findex fstore d (pure a) where findex :: a -> [e] -> a - findex a' es = foldl' f a' es + -- findex a' es = foldl' f a' es + findex a' es = foldr (flip f) a' es fstore :: a -> m a fstore a' = pure a' -run (Ix.Insert e ix) = do +run ix0@(Ix.Insert e ix) = do mix <- run ix - case mix of + case mix of Nothing -> pure Nothing - Just ix' -> Just <$> S.insert e ix' -run (Ix.Rewind n ix) = do + Just ix' -> do + nix <- S.insert e ix' + -- Debug.trace ("Result of interpreting " <> show ix0 <> " => " <> show nix <> "\n") $ Just <$> pure nix + pure $ Just nix +run ix0@(Ix.Rewind n ix) = do mix <- run ix case mix of Nothing -> pure Nothing - Just ix' -> pure $ S.rewind n ix' + -- Just ix' -> pure $ S.rewind n ix' + Just ix' -> do + let nix = S.rewind n ix' + -- Debug.trace ("Result of interpreting " <> show ix0 <> " => " <> show nix <> "\n") $ pure $ S.rewind n ix' + pure $ S.rewind n ix' + From 84b0b0b3153350d4e4df7ce98c302849393d3d4d Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 15 Mar 2022 07:51:42 +0700 Subject: [PATCH 42/62] Cleanup --- src/Index/Split.hs | 7 ++----- stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- test/Spec/Index.hs | 11 +---------- test/Spec/Split.hs | 22 ++++------------------ 5 files changed, 12 insertions(+), 38 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index f559c20f8e..8f234d7894 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -13,12 +13,9 @@ module Index.Split ) where import Data.Foldable (foldlM) -import Data.List (scanl') import Index (IndexView (..)) -import qualified Debug.Trace as Debug - data SplitIndex m a e = SplitIndex { siStoredIx :: m a -- ^ Combined view of `[e]` and `m a` @@ -31,7 +28,7 @@ data SplitIndex m a e = SplitIndex } instance (Show a, Show e) => Show (SplitIndex m a e) where - show SplitIndex{siEvents, siBuffered, siStoredIx} = + show SplitIndex{siEvents, siBuffered} = "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" storeEventsThreshold :: Int @@ -97,7 +94,7 @@ size SplitIndex {siEvents} = rewind :: Int -> SplitIndex m a e -> Maybe (SplitIndex m a e) rewind n ix@SplitIndex {siEvents} | size ix > n = Just $ ix { siEvents = drop n siEvents } - | otherwise = {-Debug.trace ("{ returing nothing from rewind " <> show (size ix) <> " " <> show n <> " }") -} Nothing + | otherwise = Nothing view :: Monad m => SplitIndex m a e -> m (IndexView a) view ix@SplitIndex{siDepth} = do diff --git a/stack.yaml b/stack.yaml index 6fae039572..2210ed2ca7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 3f6958bea8..0f88d88246 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -20,8 +20,8 @@ packages: hackage: twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 snapshots: - completed: - sha256: 79a786674930a89301b0e908fad2822a48882f3d01486117693c377b8edffdbe - size: 590102 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 + size: 590100 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/27.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 3c170ec57b..698f93add7 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -9,8 +9,6 @@ import Data.Functor.Identity (Identity, runIdentity) import Index -import qualified Debug.Trace as Debug - data Conversion m a e = Conversion { cView :: Index a e -> m (Maybe (IndexView a)) , cHistory :: Index a e -> m (Maybe [a]) @@ -107,7 +105,6 @@ prop_insertRewindInverse c (ObservedBuilder ix) = Just v' <- run $ cView c ix h <- take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) h' <- fromJust <$> run (cHistory c ix') - -- assert $ Debug.trace ("h = " <> show h <> ", h' = " <> show h' <> " bs = " <> show bs <> " ix: " <> show ix <> " ix': " <> show ix') $ h == h' assert $ h == h' -- | Generally this would not be a good property since it is very coupled @@ -124,14 +121,8 @@ prop_observeInsert c (ObservedBuilder ix) es = Just v <- run $ cView c ix let ix' = insertL es ix Just v' <- run $ cView c ix' - h <- run $ cHistory c ix' let v'' = IndexView { ixDepth = ixDepth v , ixSize = min (ixDepth v) (length es + ixSize v) , ixView = foldl' (getFunction ix) (ixView v) es } - -- assert $ v' == IndexView { ixDepth = ixDepth v - -- , ixSize = min (ixDepth v) (length bs + ixSize v) - -- , ixView = foldl' (getFunction ix) (ixView v) bs - -- } - -- assert $ Debug.trace ("History: " <> show h) True - assert $ {-Debug.trace ("v' = " <> show v' <> " v'' = " <> show v'') $-} v' == v'' + assert $ v' == v'' diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 2fb4a53ce3..42543c43d8 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -2,7 +2,6 @@ module Spec.Split where -import Data.Foldable (foldl') import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) @@ -12,8 +11,6 @@ import Index.Split (SplitIndex (..)) import qualified Index.Split as S import Spec.Index (Conversion (..)) -import qualified Debug.Trace as Debug - conversion :: (Show a, Show e) => Conversion (PropertyM IO) a e conversion = Conversion { cView = view @@ -42,8 +39,6 @@ history ix = do case mix of Nothing -> pure Nothing Just ix' -> do - h' <- S.getHistory ix' - -- h <- Debug.trace ("Getting history of " <> show ix' <> " as " <> show h') $ S.getHistory ix' h <- S.getHistory ix' pure $ Just h @@ -56,31 +51,22 @@ run :: forall m a e. (Show a, Show e, Monad m) => Index a e -> m (Maybe (SplitIndex m a e)) -run ix@(Ix.New f d a) = - let nix = S.new findex fstore d (pure a) - -- in Debug.trace ("\n Result of interpreting " <> show ix <> " => " <> show nix <> "\n") $ pure $ S.new findex fstore d (pure a) - in pure $ S.new findex fstore d (pure a) +run (Ix.New f d a) = pure $ S.new findex fstore d (pure a) where findex :: a -> [e] -> a - -- findex a' es = foldl' f a' es findex a' es = foldr (flip f) a' es fstore :: a -> m a fstore a' = pure a' -run ix0@(Ix.Insert e ix) = do +run (Ix.Insert e ix) = do mix <- run ix case mix of Nothing -> pure Nothing Just ix' -> do nix <- S.insert e ix' - -- Debug.trace ("Result of interpreting " <> show ix0 <> " => " <> show nix <> "\n") $ Just <$> pure nix pure $ Just nix -run ix0@(Ix.Rewind n ix) = do +run (Ix.Rewind n ix) = do mix <- run ix case mix of Nothing -> pure Nothing - -- Just ix' -> pure $ S.rewind n ix' - Just ix' -> do - let nix = S.rewind n ix' - -- Debug.trace ("Result of interpreting " <> show ix0 <> " => " <> show nix <> "\n") $ pure $ S.rewind n ix' - pure $ S.rewind n ix' + Just ix' -> pure $ S.rewind n ix' From a613f41a212493fc79d3c751386e3ed0db6c84f6 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 30 Mar 2022 13:25:30 +0700 Subject: [PATCH 43/62] Add notifications. --- src/Index.hs | 65 ++++++++++++++++++++++++---------------------- src/Index/Split.hs | 58 +++++++++++++++++++++-------------------- test/Spec.hs | 20 +++++++------- test/Spec/Index.hs | 50 ++++++++++++++++++----------------- test/Spec/Split.hs | 32 +++++++++++++---------- 5 files changed, 119 insertions(+), 106 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index b21d240405..049d1ad6fc 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -53,19 +53,19 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, depth >= size -} -data Index a e = New (a -> e -> a) Int a - | Insert e (Index a e) - | Rewind Int (Index a e) +data Index a e n = New (a -> e -> (a, Maybe n)) Int a + | Insert e (Index a e n) + | Rewind Int (Index a e n) -instance (Show a, Show e) => Show (Index a e) where +instance (Show a, Show e) => Show (Index a e n) where show (New _ depth acc) = "New " <> show depth <> " " <> show acc show (Insert b ix) = "Insert " <> show b <> " (" <> show ix <> ")" show (Rewind n ix) = "Rewind " <> show n <> " (" <> show ix <> ")" -newtype GrammarBuilder a e = GrammarBuilder (Index a e) +newtype GrammarBuilder a e n = GrammarBuilder (Index a e n) deriving (Show) -newtype ObservedBuilder a e = ObservedBuilder (Index a e) +newtype ObservedBuilder a e n = ObservedBuilder (Index a e n) deriving (Show) data IndexView a = IndexView @@ -76,18 +76,18 @@ data IndexView a = IndexView -- | Constructors -new :: (a -> e -> a) -> Int -> a -> Index a e +new :: (a -> e -> (a, Maybe n)) -> Int -> a -> Index a e n new = New -insert :: e -> Index a e -> Index a e +insert :: e -> Index a e n -> Index a e n insert = Insert -rewind :: Int -> Index a e -> Index a e +rewind :: Int -> Index a e n -> Index a e n rewind = Rewind -- | Observations -view :: Index a e -> Maybe (IndexView a) +view :: Index a e n -> Maybe (IndexView a) view (New _ depth initial) = if depth > 0 then pure $ IndexView { ixDepth = depth @@ -98,7 +98,7 @@ view (New _ depth initial) = view (Insert e ix) = do let f = getFunction ix v <- view ix - pure $ v { ixView = f (ixView v) e + pure $ v { ixView = fst $ f (ixView v) e , ixSize = min (ixDepth v) (ixSize v + 1) } view (Rewind n ix) = do @@ -112,18 +112,18 @@ view (Rewind n ix) = do -- | Internal -getFunction :: Index a e -> (a -> e -> a) +getFunction :: Index a e n -> (a -> e -> (a, Maybe n)) getFunction (New f _ _) = f getFunction (Insert _ ix) = getFunction ix getFunction (Rewind _ ix) = getFunction ix -getHistory :: Index a e -> Maybe [a] +getHistory :: Index a e n -> Maybe [a] getHistory (New _ _ i) = Just [i] getHistory (Insert e ix) = do let f = getFunction ix h <- getHistory ix v <- view ix - pure $ f (head h) e : take (ixDepth v - 1) h + pure $ fst (f (head h) e) : take (ixDepth v - 1) h getHistory (Rewind n ix) = do h <- getHistory ix if length h > n @@ -132,7 +132,7 @@ getHistory (Rewind n ix) = do -- | Utility -insertL :: [e] -> Index a e -> Index a e +insertL :: [e] -> Index a e n -> Index a e n insertL es ix = foldl' (flip insert) ix es -- | QuickCheck @@ -140,7 +140,8 @@ insertL es ix = foldl' (flip insert) ix es instance ( CoArbitrary a , CoArbitrary e , Arbitrary a - , Arbitrary e ) => Arbitrary (ObservedBuilder a e) where + , Arbitrary e + , Arbitrary n ) => Arbitrary (ObservedBuilder a e n) where arbitrary = sized $ \n -> do depth <- frequency [ (05, pure 1) -- overfill , (40, chooseInt (2, n + 2)) -- about filled @@ -164,7 +165,8 @@ instance ( CoArbitrary a instance ( CoArbitrary a , CoArbitrary e , Arbitrary a - , Arbitrary e ) => Arbitrary (Index a e) where + , Arbitrary e + , Arbitrary n ) => Arbitrary (Index a e n) where -- Use the ObservedIndex instance as a generator for Indexes arbitrary = do (ObservedBuilder ix) <- arbitrary @@ -174,7 +176,8 @@ instance ( CoArbitrary a instance ( CoArbitrary a , CoArbitrary e , Arbitrary a - , Arbitrary e ) => Arbitrary (GrammarBuilder a e) where + , Arbitrary e + , Arbitrary n ) => Arbitrary (GrammarBuilder a e n) where arbitrary = sized $ \n -> do depth <- frequency [ (05, pure 1) -- overfill , (40, chooseInt (2, n + 2)) -- about filled @@ -186,7 +189,7 @@ instance ( CoArbitrary a complexity <- arbitrarySizedIntegral generateGrammarIndex complexity ix -generateGrammarIndex :: Arbitrary e => Int -> Index a e -> Gen (GrammarBuilder a e) +generateGrammarIndex :: Arbitrary e => Int -> Index a e n -> Gen (GrammarBuilder a e n) generateGrammarIndex 0 ix = pure $ GrammarBuilder ix generateGrammarIndex n ix = do b <- arbitrary @@ -220,22 +223,22 @@ instance ( Ord a , Arbitrary a , Arbitrary e , CoArbitrary a - , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e) where + , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e n) where observe (IxEvents es) ix = fromJust $ view $ insertL es ix ixSignature :: [Sig] ixSignature = - [ monoObserve @(Index Int String) - , monoObserve @(Index Int Int) - , monoObserve @(Index Int [Int]) - , monoObserve @(Maybe (Index Int String)) - , monoObserve @(Maybe (Index Int Int)) - , monoObserve @(Maybe (Index Int [Int])) + [ monoObserve @(Index Int String String) + , monoObserve @(Index Int Int String) + , monoObserve @(Index Int [Int] String) + , monoObserve @(Maybe (Index Int String String)) + , monoObserve @(Maybe (Index Int Int String)) + , monoObserve @(Maybe (Index Int [Int] String)) , mono @(IndexView Int) - , con "new" (new :: (Int -> String -> Int) -> Int -> Int -> Index Int String) - , con "insert" (insert :: String -> Index Int String -> Index Int String) - , con "view" (view :: Index Int String -> Maybe (IndexView Int)) - , con "rewind" (rewind :: Int -> Index Int String -> Index Int String) - , con "getHistory" (getHistory :: Index Int String -> Maybe [Int]) + , con "new" (new :: (Int -> String -> (Int, Maybe String)) -> Int -> Int -> Index Int String String) + , con "insert" (insert :: String -> Index Int String String -> Index Int String String) + , con "view" (view :: Index Int String String -> Maybe (IndexView Int)) + , con "rewind" (rewind :: Int -> Index Int String String -> Index Int String String) + , con "getHistory" (getHistory :: Index Int String String -> Maybe [Int]) , withMaxTermSize 6 ] diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 8f234d7894..4d588e8032 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -16,18 +16,19 @@ import Data.Foldable (foldlM) import Index (IndexView (..)) -data SplitIndex m a e = SplitIndex - { siStoredIx :: m a +data SplitIndex m a e n = SplitIndex + { siStoredIx :: m a -- ^ Combined view of `[e]` and `m a` - , siEvents :: [e] - , siBuffered :: [e] - , siDepth :: Int - , siStore :: a -> m a - , siIndex :: a -> [e] -> a + , siEvents :: [e] + , siBuffered :: [e] + , siNotifications :: [n] + , siDepth :: Int + , siStore :: a -> m a + , siIndex :: a -> [e] -> (a, [n]) -- ^ Not sure how reasonble this is for a SQL db, but will leave it as-is for now } -instance (Show a, Show e) => Show (SplitIndex m a e) where +instance (Show a, Show e) => Show (SplitIndex m a e n) where show SplitIndex{siEvents, siBuffered} = "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" @@ -36,23 +37,24 @@ storeEventsThreshold = 3 new :: Monad m - => (a -> [e] -> a) + => (a -> [e] -> (a,[n])) -> (a -> m a) -> Int -> m a - -> Maybe (SplitIndex m a e) + -> Maybe (SplitIndex m a e n) new findex fstore depth ix - | depth <= 0 = Nothing - | otherwise = Just $ SplitIndex - { siStoredIx = ix - , siEvents = [] - , siBuffered = [] - , siDepth = depth - , siStore = fstore - , siIndex = findex + | depth <= 0 = Nothing + | otherwise = Just $ SplitIndex + { siStoredIx = ix + , siEvents = [] + , siBuffered = [] + , siNotifications = [] + , siDepth = depth + , siStore = fstore + , siIndex = findex } -insert :: Monad m => e -> SplitIndex m a e -> m (SplitIndex m a e) +insert :: Monad m => e -> SplitIndex m a e n -> m (SplitIndex m a e n) insert e ix@SplitIndex{siEvents, siDepth, siBuffered} | siDepth /= 1 = do let (siEvents', siBuffered') @@ -74,29 +76,29 @@ insert e ix@SplitIndex{siEvents, siDepth, siBuffered} then mergeEvents ix' else pure ix' -mergeEvents :: Monad m => SplitIndex m a e -> m (SplitIndex m a e) +mergeEvents :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do six <- siStoredIx - let six' = siIndex six siBuffered + let six' = fst $ siIndex six siBuffered nextStore <- siStore six' pure $ ix { siStoredIx = pure nextStore , siBuffered = [] } -insertL :: Monad m => [e] -> SplitIndex m a e -> m (SplitIndex m a e) +insertL :: Monad m => [e] -> SplitIndex m a e n -> m (SplitIndex m a e n) insertL es ix = foldlM (flip insert) ix es -- TODO: Do we actually need size < depth? -size :: SplitIndex m a e -> Int +size :: SplitIndex m a e n -> Int size SplitIndex {siEvents} = length siEvents + 1 -rewind :: Int -> SplitIndex m a e -> Maybe (SplitIndex m a e) +rewind :: Int -> SplitIndex m a e n -> Maybe (SplitIndex m a e n) rewind n ix@SplitIndex {siEvents} | size ix > n = Just $ ix { siEvents = drop n siEvents } | otherwise = Nothing -view :: Monad m => SplitIndex m a e -> m (IndexView a) +view :: Monad m => SplitIndex m a e n -> m (IndexView a) view ix@SplitIndex{siDepth} = do h <- getHistory ix pure $ IndexView { ixDepth = siDepth @@ -104,14 +106,14 @@ view ix@SplitIndex{siDepth} = do , ixSize = size ix } -getHistory :: forall m e a. Monad m => SplitIndex m a e -> m [a] +getHistory :: forall m e a n. Monad m => SplitIndex m a e n -> m [a] getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do storedIx <- siStoredIx let a = foldr index storedIx siBuffered pure $ scanr index a siEvents where index :: e -> a -> a - index e a = siIndex a [e] + index e a = fst $ siIndex a [e] -getEvents :: SplitIndex m a e -> [e] +getEvents :: SplitIndex m a e n -> [e] getEvents SplitIndex{siEvents} = siEvents diff --git a/test/Spec.hs b/test/Spec.hs index 3ed85962e7..d828b47342 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,29 +10,29 @@ tests = testGroup "Index" [ixProperties, siProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int Ix.conversion + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int Ix.conversion , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int Ix.conversion + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int Ix.conversion , testProperty "Rewind: Connection with `ixDepth`" $ - withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int Ix.conversion + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int Ix.conversion , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int Ix.conversion + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int Ix.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int Ix.conversion + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int Ix.conversion ] siProperties :: TestTree siProperties = testGroup "Split index" [ testProperty "New: Positive or non-positive depth" $ - withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int S.conversion , testProperty "History length is always smaller than the max depth" $ - withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int S.conversion , testProperty "Rewind: Connection with `ixDepth`" $ - withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int S.conversion , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int S.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int S.conversion + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int S.conversion ] main :: IO () diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 698f93add7..8147ae7291 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -9,23 +9,25 @@ import Data.Functor.Identity (Identity, runIdentity) import Index -data Conversion m a e = Conversion - { cView :: Index a e -> m (Maybe (IndexView a)) - , cHistory :: Index a e -> m (Maybe [a]) - , cMonadic :: m Property -> Property +data Conversion m a e n = Conversion + { cView :: Index a e n -> m (Maybe (IndexView a)) + , cHistory :: Index a e n -> m (Maybe [a]) + , cNotifications :: Index a e n -> m [n] + , cMonadic :: m Property -> Property } -conversion :: Conversion Identity a e +conversion :: Conversion Identity a e n conversion = Conversion - { cView = pure . view - , cHistory = pure . getHistory - , cMonadic = runIdentity + { cView = pure . view + , cHistory = pure . getHistory + , cNotifications = undefined + , cMonadic = runIdentity } prop_observeNew - :: forall e a m. (Eq a, Monad m) - => Conversion m a e - -> Fun (a, e) a + :: forall e a n m. (Eq a, Monad m) + => Conversion m a e n + -> Fun (a, e) (a, Maybe n) -> a -> Property prop_observeNew c f a = @@ -53,9 +55,9 @@ prop_observeNew c f a = -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) prop_rewindDepth - :: forall e a m. (Monad m) - => Conversion m a e - -> ObservedBuilder a e + :: forall e a n m. (Monad m) + => Conversion m a e n + -> ObservedBuilder a e n -> Property prop_rewindDepth c (ObservedBuilder ix) = let v = fromJust $ view ix in @@ -77,9 +79,9 @@ prop_rewindDepth c (ObservedBuilder ix) = -- | Property that validates the HF data structure. prop_sizeLEDepth - :: forall e a m. (Monad m) - => Conversion m a e - -> ObservedBuilder a e + :: forall e a n m. (Monad m) + => Conversion m a e n + -> ObservedBuilder a e n -> Property prop_sizeLEDepth c (ObservedBuilder ix) = monadic (cMonadic c) $ do @@ -88,9 +90,9 @@ prop_sizeLEDepth c (ObservedBuilder ix) = -- | Relation between Rewind and Inverse prop_insertRewindInverse - :: forall e a m. (Monad m, Show e, Show a, Arbitrary e, Eq a) - => Conversion m a e - -> ObservedBuilder a e + :: forall e a n m. (Monad m, Show e, Show a, Arbitrary e, Eq a) + => Conversion m a e n + -> ObservedBuilder a e n -> Property prop_insertRewindInverse c (ObservedBuilder ix) = let v = fromJust $ view ix @@ -111,9 +113,9 @@ prop_insertRewindInverse c (ObservedBuilder ix) = -- to the implementation, but it will be useful when trying to certify that -- another implmentation is confirming. prop_observeInsert - :: forall e a m. (Monad m, Eq a, Show a) - => Conversion m a e - -> ObservedBuilder a e + :: forall e a n m. (Monad m, Eq a, Show a) + => Conversion m a e n + -> ObservedBuilder a e n -> [e] -> Property prop_observeInsert c (ObservedBuilder ix) es = @@ -123,6 +125,6 @@ prop_observeInsert c (ObservedBuilder ix) es = Just v' <- run $ cView c ix' let v'' = IndexView { ixDepth = ixDepth v , ixSize = min (ixDepth v) (length es + ixSize v) - , ixView = foldl' (getFunction ix) (ixView v) es + , ixView = foldl' ((fst .) . getFunction ix) (ixView v) es } assert $ v' == v'' diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 42543c43d8..a3571b9dad 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -2,6 +2,7 @@ module Spec.Split where +import Data.Maybe (catMaybes) import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) @@ -11,16 +12,17 @@ import Index.Split (SplitIndex (..)) import qualified Index.Split as S import Spec.Index (Conversion (..)) -conversion :: (Show a, Show e) => Conversion (PropertyM IO) a e +conversion :: (Show a, Show e, Show n) => Conversion (PropertyM IO) a e n conversion = Conversion - { cView = view - , cHistory = history - , cMonadic = monadic + { cView = view + , cHistory = history + , cNotifications = undefined + , cMonadic = monadic } view - :: (Show a, Show e) - => Index a e + :: (Show a, Show e, Show n) + => Index a e n -> PropertyM IO (Maybe (IndexView a)) view ix = do mix <- run ix @@ -31,8 +33,8 @@ view ix = do pure $ Just v history - :: (Show a, Show e) - => Index a e + :: (Show a, Show e, Show n) + => Index a e n -> PropertyM IO (Maybe [a]) history ix = do mix <- run ix @@ -48,15 +50,19 @@ monadic monadic = monadicIO run - :: forall m a e. (Show a, Show e, Monad m) - => Index a e - -> m (Maybe (SplitIndex m a e)) + :: forall m a e n. (Show a, Show e, Show n, Monad m) + => Index a e n + -> m (Maybe (SplitIndex m a e n)) run (Ix.New f d a) = pure $ S.new findex fstore d (pure a) where - findex :: a -> [e] -> a - findex a' es = foldr (flip f) a' es + findex :: a -> [e] -> (a, [n]) + findex a' es = foldr convertIxF (a', []) es fstore :: a -> m a fstore a' = pure a' + convertIxF :: e -> (a, [n]) -> (a, [n]) + convertIxF e (a', ns) = + let (a'', mn) = f a' e + in (a'', catMaybes [mn] ++ ns) run (Ix.Insert e ix) = do mix <- run ix case mix of From 32c424bc9d91d572be5d0fc15cc54830a7437756 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 30 Mar 2022 14:18:37 +0700 Subject: [PATCH 44/62] Add notifications to the index. --- src/Index.hs | 12 +++++++++++- test/Spec.hs | 2 ++ test/Spec/Index.hs | 26 +++++++++++++++++++++----- 3 files changed, 34 insertions(+), 6 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 049d1ad6fc..57288ccc3d 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -9,6 +9,7 @@ module Index , view , getFunction , getHistory + , getNotifications -- * Helpers , insertL -- * Testing @@ -19,7 +20,7 @@ module Index import Control.Monad (replicateM) import Data.Foldable (foldl') -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, maybeToList) import GHC.Generics import QuickSpec import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, @@ -110,6 +111,15 @@ view (Rewind n ix) = do } else Nothing +getNotifications :: Index a e n -> Maybe [n] +getNotifications New{} = Just [] +getNotifications (Insert e ix) = do + let f = getFunction ix + v <- view ix + ns <- getNotifications ix + pure $ maybeToList (snd (f (ixView v) e)) ++ ns +getNotifications (Rewind _ _) = Just [] + -- | Internal getFunction :: Index a e n -> (a -> e -> (a, Maybe n)) diff --git a/test/Spec.hs b/test/Spec.hs index d828b47342..7ee6742a56 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,6 +19,8 @@ ixProperties = testGroup "Basic model" withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int Ix.conversion , testProperty "Insert is folding the structure" $ withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int Ix.conversion + , testProperty "Notifications are accumulated as the fold runs" $ + withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int Ix.conversion ] siProperties :: TestTree diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 8147ae7291..ae80e5eed2 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -1,13 +1,13 @@ module Spec.Index where +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (foldl', isPrefixOf, scanl') +import Data.Maybe (fromJust, isJust, isNothing, mapMaybe) import QuickSpec +import Test.QuickCheck.Monadic import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic -import Data.Maybe (fromJust, isJust, isNothing) -import Data.List (foldl') -import Data.Functor.Identity (Identity, runIdentity) -import Index +import Index data Conversion m a e n = Conversion { cView :: Index a e n -> m (Maybe (IndexView a)) @@ -128,3 +128,19 @@ prop_observeInsert c (ObservedBuilder ix) es = , ixView = foldl' ((fst .) . getFunction ix) (ixView v) es } assert $ v' == v'' + +-- | Notifications are accumulated as the folding function runs. +prop_observeNotifications + :: forall e a n m. (Monad m, Show n, Eq n) + => Conversion m a e n + -> ObservedBuilder a e n + -> [e] + -> Property +prop_observeNotifications c (ObservedBuilder ix) es = + monadic (cMonadic c) $ do + Just v <- run $ cView c ix + let f = getFunction ix + ix' = insertL es ix + Just ns = getNotifications ix' + ns' = mapMaybe snd $ scanl' (\(a, _) e -> f a e) (ixView v, Nothing) es + assert $ reverse ns' `isPrefixOf` ns From 5c46f0716f46b8065f6d94eaf47f955067316027 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 5 Apr 2022 11:41:58 +0700 Subject: [PATCH 45/62] Added an observation of insert for notifications. --- src/Index.hs | 3 +++ src/Index/Split.hs | 35 +++++++++++++++++++++++++++++------ test/Spec.hs | 2 ++ test/Spec/Index.hs | 6 +++--- test/Spec/Split.hs | 12 +++++++++++- 5 files changed, 48 insertions(+), 10 deletions(-) diff --git a/src/Index.hs b/src/Index.hs index 57288ccc3d..d97b9f0130 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -171,6 +171,7 @@ instance ( CoArbitrary a -- Tested with prop_hfNewReturns... let ix = new fn depth acc pure . ObservedBuilder $ insertL bs ix + shrink = shrinkNothing instance ( CoArbitrary a , CoArbitrary e @@ -198,6 +199,7 @@ instance ( CoArbitrary a let ix = new f depth acc complexity <- arbitrarySizedIntegral generateGrammarIndex complexity ix + shrink = shrinkNothing generateGrammarIndex :: Arbitrary e => Int -> Index a e n -> Gen (GrammarBuilder a e n) generateGrammarIndex 0 ix = pure $ GrammarBuilder ix @@ -220,6 +222,7 @@ instance Arbitrary a => Arbitrary (IndexView a) where , ixSize = size , ixView = view' } + shrink = shrinkNothing -- | QuickSpec diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 4d588e8032..0acbca4f18 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -10,6 +10,7 @@ module Index.Split , view , getHistory , getEvents + , getNotifications ) where import Data.Foldable (foldlM) @@ -54,7 +55,11 @@ new findex fstore depth ix , siIndex = findex } -insert :: Monad m => e -> SplitIndex m a e n -> m (SplitIndex m a e n) +insert + :: forall m a e n. Monad m + => e + -> SplitIndex m a e n + -> m (SplitIndex m a e n) insert e ix@SplitIndex{siEvents, siDepth, siBuffered} | siDepth /= 1 = do let (siEvents', siBuffered') @@ -62,24 +67,39 @@ insert e ix@SplitIndex{siEvents, siDepth, siBuffered} then ( e : take (siDepth - 2) siEvents , last siEvents : siBuffered ) else ( e : siEvents, siBuffered ) - let ix' = ix { siEvents = siEvents' - , siBuffered = siBuffered' - } + ix' <- addNotifications $ + ix { siEvents = siEvents' + , siBuffered = siBuffered' + } if length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' -- Special casing siDepth == 1 => siEvents is unused. | otherwise = do let siBuffered' = e : siBuffered - let ix' = ix { siBuffered = e : siBuffered } + ix' <- addNotifications $ + ix { siBuffered = e : siBuffered } if length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' + where + addNotifications :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) + addNotifications ix'@SplitIndex{ siNotifications + , siIndex } = do + state <- mergedState ix + let ns = snd $ siIndex state [e] + pure $ ix' { siNotifications = ns ++ siNotifications } + +mergedState :: Monad m => SplitIndex m a e n -> m a +mergedState SplitIndex{siIndex, siStoredIx, siEvents, siBuffered} = do + storedState <- siStoredIx + pure $ fst $ siIndex storedState (siEvents ++ siBuffered) + mergeEvents :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do six <- siStoredIx - let six' = fst $ siIndex six siBuffered + let six' = fst $ siIndex six siBuffered nextStore <- siStore six' pure $ ix { siStoredIx = pure nextStore , siBuffered = [] @@ -106,6 +126,9 @@ view ix@SplitIndex{siDepth} = do , ixSize = size ix } +getNotifications :: Monad m => SplitIndex m a e n -> m [n] +getNotifications SplitIndex{siNotifications} = pure siNotifications + getHistory :: forall m e a n. Monad m => SplitIndex m a e n -> m [a] getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do storedIx <- siStoredIx diff --git a/test/Spec.hs b/test/Spec.hs index 7ee6742a56..0fc5f86f57 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -35,6 +35,8 @@ siProperties = testGroup "Split index" withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int S.conversion , testProperty "Insert is folding the structure" $ withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int S.conversion + , testProperty "Notifications are accumulated as the fold runs" $ + withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int S.conversion ] main :: IO () diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index ae80e5eed2..648d03f17b 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -20,7 +20,7 @@ conversion :: Conversion Identity a e n conversion = Conversion { cView = pure . view , cHistory = pure . getHistory - , cNotifications = undefined + , cNotifications = pure . fromJust . getNotifications , cMonadic = runIdentity } @@ -131,7 +131,7 @@ prop_observeInsert c (ObservedBuilder ix) es = -- | Notifications are accumulated as the folding function runs. prop_observeNotifications - :: forall e a n m. (Monad m, Show n, Eq n) + :: forall e a n m. (Monad m, Show n, Show e, Eq n) => Conversion m a e n -> ObservedBuilder a e n -> [e] @@ -141,6 +141,6 @@ prop_observeNotifications c (ObservedBuilder ix) es = Just v <- run $ cView c ix let f = getFunction ix ix' = insertL es ix - Just ns = getNotifications ix' ns' = mapMaybe snd $ scanl' (\(a, _) e -> f a e) (ixView v, Nothing) es + ns <- run $ cNotifications c ix' assert $ reverse ns' `isPrefixOf` ns diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index a3571b9dad..52e921cf8d 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -16,7 +16,7 @@ conversion :: (Show a, Show e, Show n) => Conversion (PropertyM IO) a e n conversion = Conversion { cView = view , cHistory = history - , cNotifications = undefined + , cNotifications = notifications , cMonadic = monadic } @@ -32,6 +32,16 @@ view ix = do v <- S.view ix' pure $ Just v +notifications + :: (Show a, Show e, Show n) + => Index a e n + -> PropertyM IO [n] +notifications ix = do + -- We should never call this on invalid indexes. + Just ix' <- run ix + S.getNotifications ix' + + history :: (Show a, Show e, Show n) => Index a e n From c8a7e2bf939208b057abdf88e47f1be1e8a98dd6 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 5 Apr 2022 14:14:57 +0700 Subject: [PATCH 46/62] Added properties relating rewind to notifications. --- src/Index.hs | 2 +- test/Spec.hs | 4 ++++ test/Spec/Index.hs | 21 +++++++++++++++++++++ 3 files changed, 26 insertions(+), 1 deletion(-) diff --git a/src/Index.hs b/src/Index.hs index d97b9f0130..46b1d1dc05 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -118,7 +118,7 @@ getNotifications (Insert e ix) = do v <- view ix ns <- getNotifications ix pure $ maybeToList (snd (f (ixView v) e)) ++ ns -getNotifications (Rewind _ _) = Just [] +getNotifications (Rewind _ ix) = getNotifications ix -- | Internal diff --git a/test/Spec.hs b/test/Spec.hs index 0fc5f86f57..055152309b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,6 +21,8 @@ ixProperties = testGroup "Basic model" withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int Ix.conversion , testProperty "Notifications are accumulated as the fold runs" $ withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int Ix.conversion + , testProperty "Notifications are not affected by rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int Ix.conversion ] siProperties :: TestTree @@ -37,6 +39,8 @@ siProperties = testGroup "Split index" withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int S.conversion , testProperty "Notifications are accumulated as the fold runs" $ withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int S.conversion + , testProperty "Notifications are not affected by rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int S.conversion ] main :: IO () diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 648d03f17b..484a902565 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -144,3 +144,24 @@ prop_observeNotifications c (ObservedBuilder ix) es = ns' = mapMaybe snd $ scanl' (\(a, _) e -> f a e) (ixView v, Nothing) es ns <- run $ cNotifications c ix' assert $ reverse ns' `isPrefixOf` ns + +-- | Relation between Rewind and Inverse +prop_insertRewindNotifications + :: forall e a n m. (Monad m, Show e, Show a, Arbitrary e, Show n, Eq n) + => Conversion m a e n + -> ObservedBuilder a e n + -> Property +prop_insertRewindNotifications c (ObservedBuilder ix) = + let v = fromJust $ view ix + -- rewind does not make sense for lesser depths. + in ixDepth v >= 2 ==> + -- if the history is not fully re-written, then we can get a common + -- prefix after the insert/rewind play. We need input which is less + -- than `hfDepth hf` + forAll (resize (ixDepth v - 1) arbitrary) $ + \bs -> monadic (cMonadic c) $ do + let ix' = insertL bs ix + ix'' = rewind (length bs) ix' + ns <- run $ cNotifications c ix' + ns' <- run $ cNotifications c ix'' + assert $ ns == ns' From 3d2796ca68db031faa68f6daf8bd3df394eac023 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 6 Apr 2022 15:18:59 +0700 Subject: [PATCH 47/62] Started work on the sqlite backend. --- hysterical-screams.cabal | 3 +++ package.yaml | 1 + src/Index/Sqlite.hs | 36 ++++++++++++++++++++++++++++++++++++ 3 files changed, 40 insertions(+) create mode 100644 src/Index/Sqlite.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 3906fad9d3..2a71800197 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -30,6 +30,7 @@ library exposed-modules: Index Index.Split + Index.Sqlite other-modules: Paths_hysterical_screams hs-source-dirs: @@ -50,6 +51,7 @@ library QuickCheck , base >=4.7 && <5 , quickspec + , sqlite-simple default-language: Haskell2010 test-suite hysterical-screams-test @@ -79,6 +81,7 @@ test-suite hysterical-screams-test , containers , hysterical-screams , quickspec + , sqlite-simple , tasty , tasty-quickcheck default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 9cdf4f4bbf..e3f267e361 100644 --- a/package.yaml +++ b/package.yaml @@ -37,6 +37,7 @@ dependencies: - base >= 4.7 && < 5 - QuickCheck - quickspec +- sqlite-simple library: source-dirs: src diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs new file mode 100644 index 0000000000..94c85142ad --- /dev/null +++ b/src/Index/Sqlite.hs @@ -0,0 +1,36 @@ +module Index.Sqlite where + +import Database.SQLite.Simple (Connection, open) + +import Index.Split (SplitIndex (..)) + +data PartialStore e = + PartialStore { psConnection :: Connection + , psPendingEvents :: [e] + } + +type SqliteIndex e n = SplitIndex IO (PartialStore e) e n + +new + :: (PartialStore e -> [e] -> (PartialStore e, [n])) + -> (PartialStore e -> IO (PartialStore e)) + -> Int + -> FilePath + -> IO (Maybe (SqliteIndex e n)) +new findex fstore depth db + | depth <= 0 = pure Nothing + | otherwise = do + connection <- open db + pure . Just $ SplitIndex + { siStoredIx = pure $ PartialStore { psConnection = connection + , psPendingEvents = [] + } + , siEvents = [] + , siBuffered = [] + , siNotifications = [] + , siDepth = depth + , siStore = fstore + , siIndex = findex + } + + From 8576933bb38685d230aab2a52179d14c1e1c938b Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 6 Apr 2022 15:31:02 +0700 Subject: [PATCH 48/62] Remove `M`s from SplitIndex. --- src/Index/Split.hs | 21 +++++++++------------ src/Index/Sqlite.hs | 6 +++--- test/Spec/Split.hs | 2 +- 3 files changed, 13 insertions(+), 16 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 0acbca4f18..8cfbd4c9af 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -18,7 +18,7 @@ import Data.Foldable (foldlM) import Index (IndexView (..)) data SplitIndex m a e n = SplitIndex - { siStoredIx :: m a + { siStoredIx :: a -- ^ Combined view of `[e]` and `m a` , siEvents :: [e] , siBuffered :: [e] @@ -41,11 +41,11 @@ new => (a -> [e] -> (a,[n])) -> (a -> m a) -> Int - -> m a - -> Maybe (SplitIndex m a e n) + -> a + -> m (Maybe (SplitIndex m a e n)) new findex fstore depth ix - | depth <= 0 = Nothing - | otherwise = Just $ SplitIndex + | depth <= 0 = pure Nothing + | otherwise = pure . Just $ SplitIndex { siStoredIx = ix , siEvents = [] , siBuffered = [] @@ -92,16 +92,14 @@ insert e ix@SplitIndex{siEvents, siDepth, siBuffered} mergedState :: Monad m => SplitIndex m a e n -> m a mergedState SplitIndex{siIndex, siStoredIx, siEvents, siBuffered} = do - storedState <- siStoredIx - pure $ fst $ siIndex storedState (siEvents ++ siBuffered) + pure $ fst $ siIndex siStoredIx (siEvents ++ siBuffered) mergeEvents :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do - six <- siStoredIx - let six' = fst $ siIndex six siBuffered + let six' = fst $ siIndex siStoredIx siBuffered nextStore <- siStore six' - pure $ ix { siStoredIx = pure nextStore + pure $ ix { siStoredIx = nextStore , siBuffered = [] } @@ -131,8 +129,7 @@ getNotifications SplitIndex{siNotifications} = pure siNotifications getHistory :: forall m e a n. Monad m => SplitIndex m a e n -> m [a] getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do - storedIx <- siStoredIx - let a = foldr index storedIx siBuffered + let a = foldr index siStoredIx siBuffered pure $ scanr index a siEvents where index :: e -> a -> a diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index 94c85142ad..ce2eda6451 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -22,9 +22,9 @@ new findex fstore depth db | otherwise = do connection <- open db pure . Just $ SplitIndex - { siStoredIx = pure $ PartialStore { psConnection = connection - , psPendingEvents = [] - } + { siStoredIx = PartialStore { psConnection = connection + , psPendingEvents = [] + } , siEvents = [] , siBuffered = [] , siNotifications = [] diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 52e921cf8d..eb5db2c3f6 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -63,7 +63,7 @@ run :: forall m a e n. (Show a, Show e, Show n, Monad m) => Index a e n -> m (Maybe (SplitIndex m a e n)) -run (Ix.New f d a) = pure $ S.new findex fstore d (pure a) +run (Ix.New f d a) = S.new findex fstore d a where findex :: a -> [e] -> (a, [n]) findex a' es = foldr convertIxF (a', []) es From 68bd3676187e4d5b0aca3ba01ec86b2cc5d81937 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 6 Apr 2022 15:50:42 +0700 Subject: [PATCH 49/62] Initial implementation of the generic SQL index. --- src/Index/Sqlite.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index ce2eda6451..ef2775b030 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -1,8 +1,23 @@ -module Index.Sqlite where +module Index.Sqlite + ( -- * API + PartialStore(..) + , SqliteIndex + , new + , S.insert + , S.insertL + , S.size + , S.rewind + -- * Observations + , S.view + , S.getHistory + , S.getEvents + , S.getNotifications + ) where import Database.SQLite.Simple (Connection, open) import Index.Split (SplitIndex (..)) +import qualified Index.Split as S data PartialStore e = PartialStore { psConnection :: Connection @@ -32,5 +47,3 @@ new findex fstore depth db , siStore = fstore , siIndex = findex } - - From 81b2706f34a61f9cc9defec761ffa270b3e96789 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 7 Apr 2022 12:53:50 +0700 Subject: [PATCH 50/62] Make stIndex run in monad 'm'. It needs access to the database to get access to the latest accumulator. --- src/Index/Split.hs | 24 +++++++++++++----------- src/Index/Sqlite.hs | 2 +- test/Spec/Split.hs | 4 ++-- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 8cfbd4c9af..b5b7698db2 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -13,7 +13,7 @@ module Index.Split , getNotifications ) where -import Data.Foldable (foldlM) +import Data.Foldable (foldlM, foldrM) import Index (IndexView (..)) @@ -25,7 +25,7 @@ data SplitIndex m a e n = SplitIndex , siNotifications :: [n] , siDepth :: Int , siStore :: a -> m a - , siIndex :: a -> [e] -> (a, [n]) + , siIndex :: a -> [e] -> m (a, [n]) -- ^ Not sure how reasonble this is for a SQL db, but will leave it as-is for now } @@ -38,7 +38,7 @@ storeEventsThreshold = 3 new :: Monad m - => (a -> [e] -> (a,[n])) + => (a -> [e] -> m (a,[n])) -> (a -> m a) -> Int -> a @@ -87,18 +87,18 @@ insert e ix@SplitIndex{siEvents, siDepth, siBuffered} addNotifications ix'@SplitIndex{ siNotifications , siIndex } = do state <- mergedState ix - let ns = snd $ siIndex state [e] + ns <- snd <$> siIndex state [e] pure $ ix' { siNotifications = ns ++ siNotifications } mergedState :: Monad m => SplitIndex m a e n -> m a mergedState SplitIndex{siIndex, siStoredIx, siEvents, siBuffered} = do - pure $ fst $ siIndex siStoredIx (siEvents ++ siBuffered) + fst <$> siIndex siStoredIx (siEvents ++ siBuffered) mergeEvents :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do - let six' = fst $ siIndex siStoredIx siBuffered - nextStore <- siStore six' + six <- fst <$> siIndex siStoredIx siBuffered + nextStore <- siStore six pure $ ix { siStoredIx = nextStore , siBuffered = [] } @@ -129,11 +129,13 @@ getNotifications SplitIndex{siNotifications} = pure siNotifications getHistory :: forall m e a n. Monad m => SplitIndex m a e n -> m [a] getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do - let a = foldr index siStoredIx siBuffered - pure $ scanr index a siEvents + bas <- foldrM index [siStoredIx] siBuffered + foldrM index [head bas] siEvents where - index :: e -> a -> a - index e a = fst $ siIndex a [e] + index :: e -> [a] -> m [a] + index e as = do + (a, _) <- siIndex (head as) [e] + pure (a : as) getEvents :: SplitIndex m a e n -> [e] getEvents SplitIndex{siEvents} = siEvents diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index ef2775b030..fd090ca539 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -27,7 +27,7 @@ data PartialStore e = type SqliteIndex e n = SplitIndex IO (PartialStore e) e n new - :: (PartialStore e -> [e] -> (PartialStore e, [n])) + :: (PartialStore e -> [e] -> IO (PartialStore e, [n])) -> (PartialStore e -> IO (PartialStore e)) -> Int -> FilePath diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index eb5db2c3f6..389b009fcd 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -65,8 +65,8 @@ run -> m (Maybe (SplitIndex m a e n)) run (Ix.New f d a) = S.new findex fstore d a where - findex :: a -> [e] -> (a, [n]) - findex a' es = foldr convertIxF (a', []) es + findex :: a -> [e] -> m (a, [n]) + findex a' es = pure $ foldr convertIxF (a', []) es fstore :: a -> m a fstore a' = pure a' convertIxF :: e -> (a, [n]) -> (a, [n]) From 648dfa62bf3a8bc5cdd5a22fb1b1a1a9009a13a3 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Mon, 11 Apr 2022 20:50:34 +0700 Subject: [PATCH 51/62] Refactored the split index --- hysterical-screams.cabal | 3 + package.yaml | 1 + src/Index/Split.hs | 85 ++++++++++++++-------------- src/Index/Sqlite.hs | 24 +++----- test/Spec/Split.hs | 43 ++++++++------ test/Spec/Sqlite.hs | 117 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 199 insertions(+), 74 deletions(-) create mode 100644 test/Spec/Sqlite.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 2a71800197..5ee9bdfe9d 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -45,6 +45,7 @@ library NamedFieldPuns MultiParamTypeClasses FlexibleInstances + OverloadedStrings GADTs ghc-options: -Wall build-depends: @@ -60,6 +61,7 @@ test-suite hysterical-screams-test other-modules: Spec.Index Spec.Split + Spec.Sqlite Paths_hysterical_screams hs-source-dirs: test @@ -73,6 +75,7 @@ test-suite hysterical-screams-test NamedFieldPuns MultiParamTypeClasses FlexibleInstances + OverloadedStrings GADTs ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: diff --git a/package.yaml b/package.yaml index e3f267e361..17ea52e5e9 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ default-extensions: - NamedFieldPuns - MultiParamTypeClasses - FlexibleInstances + - OverloadedStrings - GADTs dependencies: diff --git a/src/Index/Split.hs b/src/Index/Split.hs index b5b7698db2..c99ff25deb 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -17,19 +17,19 @@ import Data.Foldable (foldlM, foldrM) import Index (IndexView (..)) -data SplitIndex m a e n = SplitIndex - { siStoredIx :: a - -- ^ Combined view of `[e]` and `m a` +data SplitIndex m h s e n = SplitIndex + { siHandle :: h , siEvents :: [e] , siBuffered :: [e] , siNotifications :: [n] , siDepth :: Int - , siStore :: a -> m a - , siIndex :: a -> [e] -> m (a, [n]) - -- ^ Not sure how reasonble this is for a SQL db, but will leave it as-is for now + , siIndex :: s -> [e] -> (s, [n]) + -- TODO: What about txs? + , siStore :: h -> s -> m () + , siLoad :: h -> m s } -instance (Show a, Show e) => Show (SplitIndex m a e n) where +instance (Show s, Show e) => Show (SplitIndex m h s e n) where show SplitIndex{siEvents, siBuffered} = "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" @@ -38,28 +38,30 @@ storeEventsThreshold = 3 new :: Monad m - => (a -> [e] -> m (a,[n])) - -> (a -> m a) + => (s -> [e] -> (s, [n])) + -> (h -> s -> m ()) + -> (h -> m s) -> Int - -> a - -> m (Maybe (SplitIndex m a e n)) -new findex fstore depth ix + -> h + -> m (Maybe (SplitIndex m h s e n)) +new findex fstore fload depth handle | depth <= 0 = pure Nothing | otherwise = pure . Just $ SplitIndex - { siStoredIx = ix + { siHandle = handle , siEvents = [] , siBuffered = [] , siNotifications = [] , siDepth = depth , siStore = fstore , siIndex = findex + , siLoad = fload } insert - :: forall m a e n. Monad m + :: forall m h s e n. Monad m => e - -> SplitIndex m a e n - -> m (SplitIndex m a e n) + -> SplitIndex m h s e n + -> m (SplitIndex m h s e n) insert e ix@SplitIndex{siEvents, siDepth, siBuffered} | siDepth /= 1 = do let (siEvents', siBuffered') @@ -83,40 +85,40 @@ insert e ix@SplitIndex{siEvents, siDepth, siBuffered} then mergeEvents ix' else pure ix' where - addNotifications :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) + addNotifications :: Monad m => SplitIndex m h s e n -> m (SplitIndex m h s e n) addNotifications ix'@SplitIndex{ siNotifications , siIndex } = do state <- mergedState ix - ns <- snd <$> siIndex state [e] + let ns = snd $ siIndex state [e] pure $ ix' { siNotifications = ns ++ siNotifications } -mergedState :: Monad m => SplitIndex m a e n -> m a -mergedState SplitIndex{siIndex, siStoredIx, siEvents, siBuffered} = do - fst <$> siIndex siStoredIx (siEvents ++ siBuffered) +mergedState :: Monad m => SplitIndex m h s e n -> m s +mergedState SplitIndex{siLoad, siIndex, siHandle, siEvents, siBuffered} = do + storedState <- siLoad siHandle + pure . fst $ siIndex storedState (siEvents ++ siBuffered) -mergeEvents :: Monad m => SplitIndex m a e n -> m (SplitIndex m a e n) -mergeEvents ix@SplitIndex {siStore, siIndex, siStoredIx, siBuffered} = do - six <- fst <$> siIndex siStoredIx siBuffered - nextStore <- siStore six - pure $ ix { siStoredIx = nextStore - , siBuffered = [] - } +mergeEvents :: Monad m => SplitIndex m h s e n -> m (SplitIndex m h s e n) +mergeEvents ix@SplitIndex {siLoad, siStore, siIndex, siHandle, siBuffered} = do + storedState <- siLoad siHandle + let updatedStoreState = fst $ siIndex storedState siBuffered + _ <- siStore siHandle updatedStoreState + pure $ ix { siBuffered = [] } -insertL :: Monad m => [e] -> SplitIndex m a e n -> m (SplitIndex m a e n) +insertL :: Monad m => [e] -> SplitIndex m h s e n -> m (SplitIndex m h s e n) insertL es ix = foldlM (flip insert) ix es -- TODO: Do we actually need size < depth? -size :: SplitIndex m a e n -> Int +size :: SplitIndex m h s e n -> Int size SplitIndex {siEvents} = length siEvents + 1 -rewind :: Int -> SplitIndex m a e n -> Maybe (SplitIndex m a e n) +rewind :: Int -> SplitIndex m h s e n -> Maybe (SplitIndex m h s e n) rewind n ix@SplitIndex {siEvents} | size ix > n = Just $ ix { siEvents = drop n siEvents } | otherwise = Nothing -view :: Monad m => SplitIndex m a e n -> m (IndexView a) +view :: Monad m => SplitIndex m h s e n -> m (IndexView s) view ix@SplitIndex{siDepth} = do h <- getHistory ix pure $ IndexView { ixDepth = siDepth @@ -124,18 +126,19 @@ view ix@SplitIndex{siDepth} = do , ixSize = size ix } -getNotifications :: Monad m => SplitIndex m a e n -> m [n] +getNotifications :: Monad m => SplitIndex m h s e n -> m [n] getNotifications SplitIndex{siNotifications} = pure siNotifications -getHistory :: forall m e a n. Monad m => SplitIndex m a e n -> m [a] -getHistory SplitIndex{siStoredIx, siIndex, siEvents, siBuffered} = do - bas <- foldrM index [siStoredIx] siBuffered - foldrM index [head bas] siEvents +getHistory :: forall m h e s n. Monad m => SplitIndex m h s e n -> m [s] +getHistory SplitIndex{siLoad, siHandle, siIndex, siEvents, siBuffered} = do + storedState <- siLoad siHandle + let bas = foldr index [storedState] siBuffered + pure $ foldr index [head bas] siEvents where - index :: e -> [a] -> m [a] + index :: e -> [s] -> [s] index e as = do - (a, _) <- siIndex (head as) [e] - pure (a : as) + let (a, _) = siIndex (head as) [e] + a : as -getEvents :: SplitIndex m a e n -> [e] +getEvents :: SplitIndex m h s e n -> [e] getEvents SplitIndex{siEvents} = siEvents diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index fd090ca539..d83466df74 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -1,7 +1,6 @@ module Index.Sqlite ( -- * API - PartialStore(..) - , SqliteIndex + SqliteIndex , new , S.insert , S.insertL @@ -19,31 +18,26 @@ import Database.SQLite.Simple (Connection, open) import Index.Split (SplitIndex (..)) import qualified Index.Split as S -data PartialStore e = - PartialStore { psConnection :: Connection - , psPendingEvents :: [e] - } - -type SqliteIndex e n = SplitIndex IO (PartialStore e) e n +type SqliteIndex a e n = SplitIndex IO Connection a e n new - :: (PartialStore e -> [e] -> IO (PartialStore e, [n])) - -> (PartialStore e -> IO (PartialStore e)) + :: (a -> [e] -> (a, [n])) + -> (Connection -> a -> IO ()) + -> (Connection -> IO a) -> Int -> FilePath - -> IO (Maybe (SqliteIndex e n)) -new findex fstore depth db + -> IO (Maybe (SqliteIndex a e n)) +new findex fstore fload depth db | depth <= 0 = pure Nothing | otherwise = do connection <- open db pure . Just $ SplitIndex - { siStoredIx = PartialStore { psConnection = connection - , psPendingEvents = [] - } + { siHandle = connection , siEvents = [] , siBuffered = [] , siNotifications = [] , siDepth = depth , siStore = fstore + , siLoad = fload , siIndex = findex } diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 389b009fcd..254d123260 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -2,6 +2,8 @@ module Spec.Split where +import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) +import Control.Monad.IO.Class (liftIO) import Data.Maybe (catMaybes) import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) @@ -12,7 +14,7 @@ import Index.Split (SplitIndex (..)) import qualified Index.Split as S import Spec.Index (Conversion (..)) -conversion :: (Show a, Show e, Show n) => Conversion (PropertyM IO) a e n +conversion :: (Show s, Show e, Show n) => Conversion (PropertyM IO) s e n conversion = Conversion { cView = view , cHistory = history @@ -21,14 +23,14 @@ conversion = Conversion } view - :: (Show a, Show e, Show n) - => Index a e n - -> PropertyM IO (Maybe (IndexView a)) + :: (Show s, Show e, Show n) + => Index s e n + -> PropertyM IO (Maybe (IndexView s)) view ix = do mix <- run ix case mix of Nothing -> pure Nothing - Just ix' -> do + Just ix' -> liftIO $ do v <- S.view ix' pure $ Just v @@ -39,7 +41,7 @@ notifications notifications ix = do -- We should never call this on invalid indexes. Just ix' <- run ix - S.getNotifications ix' + liftIO $ S.getNotifications ix' history @@ -50,7 +52,7 @@ history ix = do mix <- run ix case mix of Nothing -> pure Nothing - Just ix' -> do + Just ix' -> liftIO $ do h <- S.getHistory ix' pure $ Just h @@ -60,16 +62,21 @@ monadic monadic = monadicIO run - :: forall m a e n. (Show a, Show e, Show n, Monad m) - => Index a e n - -> m (Maybe (SplitIndex m a e n)) -run (Ix.New f d a) = S.new findex fstore d a + :: forall s e n. (Show s, Show e, Show n) + => Index s e n + -> PropertyM IO (Maybe (SplitIndex IO (MVar s) s e n)) +run (Ix.New f depth store) = do + liftIO $ do + mstore <- newMVar store + S.new findex fstore fload depth mstore where - findex :: a -> [e] -> m (a, [n]) - findex a' es = pure $ foldr convertIxF (a', []) es - fstore :: a -> m a - fstore a' = pure a' - convertIxF :: e -> (a, [n]) -> (a, [n]) + findex :: s -> [e] -> (s, [n]) + findex s es = foldr convertIxF (s, []) es + fstore :: MVar s -> s -> IO () + fstore mv s = swapMVar mv s >> pure () + fload :: MVar s -> IO s + fload = readMVar + convertIxF :: e -> (s, [n]) -> (s, [n]) convertIxF e (a', ns) = let (a'', mn) = f a' e in (a'', catMaybes [mn] ++ ns) @@ -77,12 +84,12 @@ run (Ix.Insert e ix) = do mix <- run ix case mix of Nothing -> pure Nothing - Just ix' -> do + Just ix' -> liftIO $ do nix <- S.insert e ix' pure $ Just nix run (Ix.Rewind n ix) = do mix <- run ix case mix of Nothing -> pure Nothing - Just ix' -> pure $ S.rewind n ix' + Just ix' -> liftIO . pure $ S.rewind n ix' diff --git a/test/Spec/Sqlite.hs b/test/Spec/Sqlite.hs new file mode 100644 index 0000000000..69b83b8888 --- /dev/null +++ b/test/Spec/Sqlite.hs @@ -0,0 +1,117 @@ +module Spec.Sqlite where + +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (catMaybes) +import Database.SQLite.Simple (execute_, execute, Only(..)) +import Test.QuickCheck (Property) +import Test.QuickCheck.Monadic (PropertyM, monadicIO) +import qualified Test.QuickCheck.Monadic as M + +import Index (Index, IndexView (..)) +import qualified Index as Ix +import Index.Split (SplitIndex(..)) +import Index.Sqlite (SqliteIndex (..)) +import qualified Index.Sqlite as S +import Spec.Index (Conversion (..)) + +conversion :: (Show e, Show n, Show a) => Conversion (PropertyM IO) a e n +conversion = Conversion + { cView = view + , cHistory = undefined + , cNotifications = undefined + , cMonadic = undefined + } + +-- conversion :: (Show a, Show e, Show n) => Conversion (PropertyM IO) a e n +-- conversion = Conversion +-- { cView = view +-- , cHistory = history +-- , cNotifications = notifications +-- , cMonadic = monadic +-- } + +view + :: (Show a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe (IndexView a)) +view ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> do + v <- M.run $ S.view ix' + pure $ Just v + +-- notifications +-- :: (Show a, Show e, Show n) +-- => Index a e n +-- -> PropertyM IO [n] +-- notifications ix = do +-- -- We should never call this on invalid indexes. +-- Just ix' <- run ix +-- S.getNotifications ix' + +-- history +-- :: (Show a, Show e, Show n) +-- => Index a e n +-- -> PropertyM IO (Maybe [a]) +-- history ix = do +-- mix <- run ix +-- case mix of +-- Nothing -> pure Nothing +-- Just ix' -> do +-- h <- S.getHistory ix' +-- pure $ Just h + +-- monadic +-- :: PropertyM IO Property +-- -> Property +-- monadic = monadicIO + +run + :: forall a e n. (Show a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe (SqliteIndex a e n)) +run (Ix.New f d a) = undefined +-- run (Ix.New f d a) = do +-- Just sqliteIndex <- liftIO $ S.new findex fstore d "sqlite-index-property-tests.sqlite" +-- let (PartialStore c _) = siStoredIx sqliteIndex +-- -- Initialise database +-- liftIO $ do +-- execute_ c "DROP TABLE IF EXISTS sqlite-index-property-tests" +-- execute_ c "CREATE TABLE sqlite-index-property-tests (id INTEGER PRIMARY KEY, accumulator TEXT)" +-- execute c "INSERT INTO sqlite-index-property-tests (id, accumulator) VALUES ?" (1, a) +-- pure $ Just sqliteIndex +-- where +-- findex :: PartialStore e -> [e] -> IO (PartialStore e, [n]) +-- -- TODO: Is es' always supposed to be empty when calling this function? +-- findex (PartialStore c es') es = do +-- -- TODO: Potential race condition (do we care?) +-- storedAcc <- execute c "SELECT (accumulator) from sqlite-index-property-tests WHERE id = ?" (Only 1) +-- pure $ foldr convertIxF (storedAcc, []) (es' ++ es) +-- fstore :: PartialStore e -> IO (PartialStore e) +-- fstore (PartialStore c es) = do +-- execute_ c "BEGIN" +-- storedAcc <- execute c "SELECT (accumulator) FROM sqlite-index-property-tests WHERE id = ?" (Only 1) +-- let nextAcc = fst $ foldr convertIxF (storedAcc, []) es +-- execute c "UPDATE sqlite-index-property-tests (accumulator = ?) WHERE id = ?" (nextAcc, 1) +-- execute c "COMMIT" +-- pure $ PartialStore c [] +-- convertIxF :: e -> (PartialStore e, [n]) -> (PartialStore e, [n]) +-- convertIxF e (a', ns) = +-- let (a'', mn) = f a' e +-- in (a'', catMaybes [mn] ++ ns) +run (Ix.Insert e ix) = undefined +-- run (Ix.Insert e ix) = do +-- mix <- run ix +-- case mix of +-- Nothing -> pure Nothing +-- Just ix' -> do +-- nix <- S.insert e ix' +-- pure $ Just nix +run (Ix.Rewind n ix) = undefined +-- run (Ix.Rewind n ix) = do +-- mix <- run ix +-- case mix of +-- Nothing -> pure Nothing +-- Just ix' -> pure $ S.rewind n ix' From 9e355af1fa42cba0b9bd8dd1f1a7e73b09483a21 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 12 Apr 2022 00:43:49 +0700 Subject: [PATCH 52/62] Make the sqlindex pass tests. --- test/Spec.hs | 21 +++++- test/Spec/Sqlite.hs | 153 ++++++++++++++++++++------------------------ 2 files changed, 91 insertions(+), 83 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 055152309b..90968cc97e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,9 +3,10 @@ import Test.Tasty.QuickCheck import qualified Spec.Index as Ix import qualified Spec.Split as S +import qualified Spec.Sqlite as Sqlite tests :: TestTree -tests = testGroup "Index" [ixProperties, siProperties] +tests = testGroup "Index" [ixProperties, siProperties, sqProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" @@ -43,6 +44,24 @@ siProperties = testGroup "Split index" withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int S.conversion ] +sqProperties :: TestTree +sqProperties = testGroup "Sqlite index" + [ testProperty "New: Positive or non-positive depth" $ + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int Sqlite.conversion + , testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int Sqlite.conversion + , testProperty "Rewind: Connection with `ixDepth`" $ + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int Sqlite.conversion + , testProperty "Relationship between Insert/Rewind" $ + withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int Sqlite.conversion + , testProperty "Insert is folding the structure" $ + withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int Sqlite.conversion + , testProperty "Notifications are accumulated as the fold runs" $ + withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int Sqlite.conversion + , testProperty "Notifications are not affected by rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int Sqlite.conversion + ] + main :: IO () main = do -- quickSpec ixSignature diff --git a/test/Spec/Sqlite.hs b/test/Spec/Sqlite.hs index 69b83b8888..e495f234ad 100644 --- a/test/Spec/Sqlite.hs +++ b/test/Spec/Sqlite.hs @@ -2,7 +2,9 @@ module Spec.Sqlite where import Control.Monad.IO.Class (liftIO) import Data.Maybe (catMaybes) -import Database.SQLite.Simple (execute_, execute, Only(..)) +import Database.SQLite.Simple (Connection, query, execute_, execute, Only(..)) +import Database.SQLite.Simple.ToField +import Database.SQLite.Simple.FromField import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) import qualified Test.QuickCheck.Monadic as M @@ -10,28 +12,20 @@ import qualified Test.QuickCheck.Monadic as M import Index (Index, IndexView (..)) import qualified Index as Ix import Index.Split (SplitIndex(..)) -import Index.Sqlite (SqliteIndex (..)) +import Index.Sqlite (SqliteIndex) import qualified Index.Sqlite as S import Spec.Index (Conversion (..)) -conversion :: (Show e, Show n, Show a) => Conversion (PropertyM IO) a e n +conversion :: (Show e, Show n, Show a, ToField a, FromField a) => Conversion (PropertyM IO) a e n conversion = Conversion { cView = view - , cHistory = undefined - , cNotifications = undefined - , cMonadic = undefined + , cHistory = history + , cNotifications = notifications + , cMonadic = monadic } --- conversion :: (Show a, Show e, Show n) => Conversion (PropertyM IO) a e n --- conversion = Conversion --- { cView = view --- , cHistory = history --- , cNotifications = notifications --- , cMonadic = monadic --- } - view - :: (Show a, Show e, Show n) + :: (Show a, ToField a, FromField a, Show e, Show n) => Index a e n -> PropertyM IO (Maybe (IndexView a)) view ix = do @@ -42,76 +36,71 @@ view ix = do v <- M.run $ S.view ix' pure $ Just v --- notifications --- :: (Show a, Show e, Show n) --- => Index a e n --- -> PropertyM IO [n] --- notifications ix = do --- -- We should never call this on invalid indexes. --- Just ix' <- run ix --- S.getNotifications ix' +notifications + :: (Show a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO [n] +notifications ix = do + -- We should never call this on invalid indexes. + Just ix' <- run ix + liftIO $ S.getNotifications ix' --- history --- :: (Show a, Show e, Show n) --- => Index a e n --- -> PropertyM IO (Maybe [a]) --- history ix = do --- mix <- run ix --- case mix of --- Nothing -> pure Nothing --- Just ix' -> do --- h <- S.getHistory ix' --- pure $ Just h +history + :: (Show a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe [a]) +history ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + h <- S.getHistory ix' + pure $ Just h --- monadic --- :: PropertyM IO Property --- -> Property --- monadic = monadicIO +monadic + :: PropertyM IO Property + -> Property +monadic = monadicIO run - :: forall a e n. (Show a, Show e, Show n) + :: forall a e n. (Show a, ToField a, FromField a, Show e, Show n) => Index a e n -> PropertyM IO (Maybe (SqliteIndex a e n)) -run (Ix.New f d a) = undefined --- run (Ix.New f d a) = do --- Just sqliteIndex <- liftIO $ S.new findex fstore d "sqlite-index-property-tests.sqlite" --- let (PartialStore c _) = siStoredIx sqliteIndex --- -- Initialise database --- liftIO $ do --- execute_ c "DROP TABLE IF EXISTS sqlite-index-property-tests" --- execute_ c "CREATE TABLE sqlite-index-property-tests (id INTEGER PRIMARY KEY, accumulator TEXT)" --- execute c "INSERT INTO sqlite-index-property-tests (id, accumulator) VALUES ?" (1, a) --- pure $ Just sqliteIndex --- where --- findex :: PartialStore e -> [e] -> IO (PartialStore e, [n]) --- -- TODO: Is es' always supposed to be empty when calling this function? --- findex (PartialStore c es') es = do --- -- TODO: Potential race condition (do we care?) --- storedAcc <- execute c "SELECT (accumulator) from sqlite-index-property-tests WHERE id = ?" (Only 1) --- pure $ foldr convertIxF (storedAcc, []) (es' ++ es) --- fstore :: PartialStore e -> IO (PartialStore e) --- fstore (PartialStore c es) = do --- execute_ c "BEGIN" --- storedAcc <- execute c "SELECT (accumulator) FROM sqlite-index-property-tests WHERE id = ?" (Only 1) --- let nextAcc = fst $ foldr convertIxF (storedAcc, []) es --- execute c "UPDATE sqlite-index-property-tests (accumulator = ?) WHERE id = ?" (nextAcc, 1) --- execute c "COMMIT" --- pure $ PartialStore c [] --- convertIxF :: e -> (PartialStore e, [n]) -> (PartialStore e, [n]) --- convertIxF e (a', ns) = --- let (a'', mn) = f a' e --- in (a'', catMaybes [mn] ++ ns) -run (Ix.Insert e ix) = undefined --- run (Ix.Insert e ix) = do --- mix <- run ix --- case mix of --- Nothing -> pure Nothing --- Just ix' -> do --- nix <- S.insert e ix' --- pure $ Just nix -run (Ix.Rewind n ix) = undefined --- run (Ix.Rewind n ix) = do --- mix <- run ix --- case mix of --- Nothing -> pure Nothing --- Just ix' -> pure $ S.rewind n ix' +run (Ix.New f depth acc) = do + sqliteIndex <- liftIO $ S.new findex fstore fload depth ":memory:" + case sqliteIndex of + Nothing -> pure Nothing + Just ix -> do + let c = siHandle ix + -- Initialise database + liftIO $ do + execute_ c "DROP TABLE IF EXISTS index_property_tests" + execute_ c "CREATE TABLE index_property_tests (id INTEGER PRIMARY KEY, accumulator INT)" + execute c "INSERT INTO index_property_tests (id, accumulator) VALUES (?, ?)" (1 :: Int, acc) + pure . Just $ ix + where + findex :: a -> [e] -> (a, [n]) + findex a es = foldr convertIxF (a, []) es + fstore :: Connection -> a -> IO () + fstore c a = + execute c "UPDATE index_property_tests SET accumulator = ? WHERE id = ?" (a, 1 :: Int) + fload :: Connection -> IO a + fload c = do + [[a]] <- query c "SELECT (accumulator) FROM index_property_tests WHERE id = ?" (Only 1 :: Only Int) + pure a + convertIxF :: e -> (a, [n]) -> (a, [n]) + convertIxF e (a, ns) = + let (a', mn) = f a e + in (a', catMaybes [mn] ++ ns) +run (Ix.Insert e ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + nix <- S.insert e ix' + pure $ Just nix +run (Ix.Rewind n ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO . pure $ S.rewind n ix' From 211c478343eb7cf3651af22fb550c3b3f0d80bc7 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Sat, 16 Apr 2022 15:40:35 +0700 Subject: [PATCH 53/62] Make `SplitIndex` work with partial results. --- hysterical-screams.cabal | 2 + package.yaml | 1 + src/Index/Split.hs | 104 +++++++++++++++------------------------ src/Index/Sqlite.hs | 19 ++++--- test/Spec/Split.hs | 52 +++++++++++--------- test/Spec/Sqlite.hs | 76 +++++++++++++++------------- 6 files changed, 126 insertions(+), 128 deletions(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 5ee9bdfe9d..7a37e837a1 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -51,6 +51,7 @@ library build-depends: QuickCheck , base >=4.7 && <5 + , data-default , quickspec , sqlite-simple default-language: Haskell2010 @@ -82,6 +83,7 @@ test-suite hysterical-screams-test QuickCheck , base >=4.7 && <5 , containers + , data-default , hysterical-screams , quickspec , sqlite-simple diff --git a/package.yaml b/package.yaml index 17ea52e5e9..927185d1fc 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ dependencies: - QuickCheck - quickspec - sqlite-simple +- data-default library: source-dirs: src diff --git a/src/Index/Split.hs b/src/Index/Split.hs index c99ff25deb..f3a659aaae 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -9,27 +9,27 @@ module Index.Split -- * Observations , view , getHistory - , getEvents , getNotifications ) where -import Data.Foldable (foldlM, foldrM) +import Data.List (tails) +import Data.Foldable (foldlM) -import Index (IndexView (..)) +import Index (IndexView (..)) -data SplitIndex m h s e n = SplitIndex +data SplitIndex m h e n q r = SplitIndex { siHandle :: h , siEvents :: [e] , siBuffered :: [e] , siNotifications :: [n] , siDepth :: Int - , siIndex :: s -> [e] -> (s, [n]) -- TODO: What about txs? - , siStore :: h -> s -> m () - , siLoad :: h -> m s + , siStore :: SplitIndex m h e n q r -> m () + , siQuery :: SplitIndex m h e n q r -> q -> [e] -> m r + , siOnInsert :: e -> SplitIndex m h e n q r -> m [n] } -instance (Show s, Show e) => Show (SplitIndex m h s e n) where +instance (Show r, Show e) => Show (SplitIndex m h e n q r) where show SplitIndex{siEvents, siBuffered} = "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" @@ -38,13 +38,13 @@ storeEventsThreshold = 3 new :: Monad m - => (s -> [e] -> (s, [n])) - -> (h -> s -> m ()) - -> (h -> m s) + => (SplitIndex m h e n q r -> q -> [e] -> m r) + -> (e -> SplitIndex m h e n q r -> m [n]) + -> (SplitIndex m h e n q r -> m ()) -> Int -> h - -> m (Maybe (SplitIndex m h s e n)) -new findex fstore fload depth handle + -> m (Maybe (SplitIndex m h e n q r)) +new fquery foninsert fstore depth handle | depth <= 0 = pure Nothing | otherwise = pure . Just $ SplitIndex { siHandle = handle @@ -53,92 +53,70 @@ new findex fstore fload depth handle , siNotifications = [] , siDepth = depth , siStore = fstore - , siIndex = findex - , siLoad = fload + , siQuery = fquery + , siOnInsert = foninsert } insert - :: forall m h s e n. Monad m + :: forall m h e n q r. Monad m => e - -> SplitIndex m h s e n - -> m (SplitIndex m h s e n) -insert e ix@SplitIndex{siEvents, siDepth, siBuffered} + -> SplitIndex m h e n q r + -> m (SplitIndex m h e n q r) +insert e ix@SplitIndex{siOnInsert, siNotifications, siEvents, siDepth, siBuffered} | siDepth /= 1 = do let (siEvents', siBuffered') = if size ix == siDepth then ( e : take (siDepth - 2) siEvents , last siEvents : siBuffered ) else ( e : siEvents, siBuffered ) - ix' <- addNotifications $ - ix { siEvents = siEvents' - , siBuffered = siBuffered' - } + ns <- siOnInsert e ix + let ix' = ix { siEvents = siEvents' + , siBuffered = siBuffered' + , siNotifications = ns ++ siNotifications + } if length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' -- Special casing siDepth == 1 => siEvents is unused. | otherwise = do let siBuffered' = e : siBuffered - ix' <- addNotifications $ - ix { siBuffered = e : siBuffered } + ns <- siOnInsert e ix + let ix' = ix { siBuffered = e : siBuffered + , siNotifications = ns ++ siNotifications + } if length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' - where - addNotifications :: Monad m => SplitIndex m h s e n -> m (SplitIndex m h s e n) - addNotifications ix'@SplitIndex{ siNotifications - , siIndex } = do - state <- mergedState ix - let ns = snd $ siIndex state [e] - pure $ ix' { siNotifications = ns ++ siNotifications } -mergedState :: Monad m => SplitIndex m h s e n -> m s -mergedState SplitIndex{siLoad, siIndex, siHandle, siEvents, siBuffered} = do - storedState <- siLoad siHandle - pure . fst $ siIndex storedState (siEvents ++ siBuffered) - - -mergeEvents :: Monad m => SplitIndex m h s e n -> m (SplitIndex m h s e n) -mergeEvents ix@SplitIndex {siLoad, siStore, siIndex, siHandle, siBuffered} = do - storedState <- siLoad siHandle - let updatedStoreState = fst $ siIndex storedState siBuffered - _ <- siStore siHandle updatedStoreState +mergeEvents :: Monad m => SplitIndex m h e n q r -> m (SplitIndex m h e n q r) +mergeEvents ix@SplitIndex{siStore} = do + _ <- siStore ix pure $ ix { siBuffered = [] } -insertL :: Monad m => [e] -> SplitIndex m h s e n -> m (SplitIndex m h s e n) +insertL :: Monad m => [e] -> SplitIndex m h e n q r -> m (SplitIndex m h e n q r) insertL es ix = foldlM (flip insert) ix es -- TODO: Do we actually need size < depth? -size :: SplitIndex m h s e n -> Int +size :: SplitIndex m h e n q r -> Int size SplitIndex {siEvents} = length siEvents + 1 -rewind :: Int -> SplitIndex m h s e n -> Maybe (SplitIndex m h s e n) +rewind :: Int -> SplitIndex m h e n q r -> Maybe (SplitIndex m h e n q r) rewind n ix@SplitIndex {siEvents} | size ix > n = Just $ ix { siEvents = drop n siEvents } | otherwise = Nothing -view :: Monad m => SplitIndex m h s e n -> m (IndexView s) -view ix@SplitIndex{siDepth} = do - h <- getHistory ix +view :: Monad m => q -> SplitIndex m h e n q r -> m (IndexView r) +view query ix@SplitIndex{siDepth} = do + h <- getHistory query ix pure $ IndexView { ixDepth = siDepth , ixView = head h , ixSize = size ix } -getNotifications :: Monad m => SplitIndex m h s e n -> m [n] +getNotifications :: Monad m => SplitIndex m h e n q r -> m [n] getNotifications SplitIndex{siNotifications} = pure siNotifications -getHistory :: forall m h e s n. Monad m => SplitIndex m h s e n -> m [s] -getHistory SplitIndex{siLoad, siHandle, siIndex, siEvents, siBuffered} = do - storedState <- siLoad siHandle - let bas = foldr index [storedState] siBuffered - pure $ foldr index [head bas] siEvents - where - index :: e -> [s] -> [s] - index e as = do - let (a, _) = siIndex (head as) [e] - a : as - -getEvents :: SplitIndex m h s e n -> [e] -getEvents SplitIndex{siEvents} = siEvents +getHistory :: forall m h e n q r. Monad m => q -> SplitIndex m h e n q r -> m [r] +getHistory query ix@SplitIndex{siQuery, siEvents} = + mapM (siQuery ix query) $ tails siEvents diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index d83466df74..022001f316 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -9,25 +9,24 @@ module Index.Sqlite -- * Observations , S.view , S.getHistory - , S.getEvents , S.getNotifications ) where import Database.SQLite.Simple (Connection, open) import Index.Split (SplitIndex (..)) -import qualified Index.Split as S +import qualified Index.Split as S -type SqliteIndex a e n = SplitIndex IO Connection a e n +type SqliteIndex e n q r = SplitIndex IO Connection e n q r new - :: (a -> [e] -> (a, [n])) - -> (Connection -> a -> IO ()) - -> (Connection -> IO a) + :: (SqliteIndex e n q r -> q -> [e] -> IO r) + -> (e -> SqliteIndex e n q r -> IO [n]) + -> (SqliteIndex e n q r -> IO ()) -> Int -> FilePath - -> IO (Maybe (SqliteIndex a e n)) -new findex fstore fload depth db + -> IO (Maybe (SqliteIndex e n q r)) +new fquery foninsert fstore depth db | depth <= 0 = pure Nothing | otherwise = do connection <- open db @@ -38,6 +37,6 @@ new findex fstore fload depth db , siNotifications = [] , siDepth = depth , siStore = fstore - , siLoad = fload - , siIndex = findex + , siQuery = fquery + , siOnInsert = foninsert } diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 254d123260..3fd6586fd7 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} - module Spec.Split where -import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) -import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Default import Data.Maybe (catMaybes) import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) @@ -14,7 +13,7 @@ import Index.Split (SplitIndex (..)) import qualified Index.Split as S import Spec.Index (Conversion (..)) -conversion :: (Show s, Show e, Show n) => Conversion (PropertyM IO) s e n +conversion :: (Show s, Show e, Show n, Default s) => Conversion (PropertyM IO) s e n conversion = Conversion { cView = view , cHistory = history @@ -23,7 +22,7 @@ conversion = Conversion } view - :: (Show s, Show e, Show n) + :: (Show s, Show e, Show n, Default s) => Index s e n -> PropertyM IO (Maybe (IndexView s)) view ix = do @@ -31,11 +30,11 @@ view ix = do case mix of Nothing -> pure Nothing Just ix' -> liftIO $ do - v <- S.view ix' + v <- S.view () ix' pure $ Just v notifications - :: (Show a, Show e, Show n) + :: (Show a, Show e, Show n, Default a) => Index a e n -> PropertyM IO [n] notifications ix = do @@ -45,15 +44,15 @@ notifications ix = do history - :: (Show a, Show e, Show n) - => Index a e n - -> PropertyM IO (Maybe [a]) + :: (Show s, Show e, Show n, Default s) + => Index s e n + -> PropertyM IO (Maybe [s]) history ix = do mix <- run ix case mix of Nothing -> pure Nothing Just ix' -> liftIO $ do - h <- S.getHistory ix' + h <- S.getHistory () ix' pure $ Just h monadic @@ -61,28 +60,37 @@ monadic -> Property monadic = monadicIO +{- | TODO: Make the case why this interpretation tests something useful. +-} run - :: forall s e n. (Show s, Show e, Show n) + :: forall s e n. (Show s, Show e, Show n, Default s) => Index s e n - -> PropertyM IO (Maybe (SplitIndex IO (MVar s) s e n)) + -> PropertyM IO (Maybe (SplitIndex IO (MVar s) e n () s)) run (Ix.New f depth store) = do liftIO $ do mstore <- newMVar store - S.new findex fstore fload depth mstore + S.new fquery foninsert fstore depth mstore where - findex :: s -> [e] -> (s, [n]) - findex s es = foldr convertIxF (s, []) es - fstore :: MVar s -> s -> IO () - fstore mv s = swapMVar mv s >> pure () - fload :: MVar s -> IO s - fload = readMVar + fquery :: SplitIndex IO (MVar s) e n () s -> () -> [e] -> IO s + fquery SplitIndex{siHandle, siBuffered} () es = do + oldState <- readMVar siHandle + pure . fst $ foldr convertIxF (oldState, []) (es ++ siBuffered) + fstore :: SplitIndex IO (MVar s) e n () s -> IO () + fstore ix@SplitIndex{siHandle} = do + newState <- fquery ix () [] + _ <- swapMVar siHandle newState + pure () + foninsert :: e -> SplitIndex IO (MVar s) e n () s -> IO [n] + foninsert e ix@SplitIndex{siEvents} = do + oldState <- fquery ix () siEvents + pure $ catMaybes [snd $ f oldState e] convertIxF :: e -> (s, [n]) -> (s, [n]) convertIxF e (a', ns) = let (a'', mn) = f a' e in (a'', catMaybes [mn] ++ ns) run (Ix.Insert e ix) = do mix <- run ix - case mix of + case mix of Nothing -> pure Nothing Just ix' -> liftIO $ do nix <- S.insert e ix' diff --git a/test/Spec/Sqlite.hs b/test/Spec/Sqlite.hs index e495f234ad..5d65b3c838 100644 --- a/test/Spec/Sqlite.hs +++ b/test/Spec/Sqlite.hs @@ -1,22 +1,26 @@ module Spec.Sqlite where -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (catMaybes) -import Database.SQLite.Simple (Connection, query, execute_, execute, Only(..)) -import Database.SQLite.Simple.ToField -import Database.SQLite.Simple.FromField -import Test.QuickCheck (Property) -import Test.QuickCheck.Monadic (PropertyM, monadicIO) -import qualified Test.QuickCheck.Monadic as M +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.Maybe (catMaybes) +import Database.SQLite.Simple (Only (..), execute, execute_, + query) +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import Test.QuickCheck (Property) +import Test.QuickCheck.Monadic (PropertyM, monadicIO) +import qualified Test.QuickCheck.Monadic as M -import Index (Index, IndexView (..)) -import qualified Index as Ix -import Index.Split (SplitIndex(..)) -import Index.Sqlite (SqliteIndex) -import qualified Index.Sqlite as S -import Spec.Index (Conversion (..)) +import Index (Index, IndexView (..)) +import qualified Index as Ix +import Index.Split (SplitIndex (..)) +import Index.Sqlite (SqliteIndex) +import qualified Index.Sqlite as S +import Spec.Index (Conversion (..)) -conversion :: (Show e, Show n, Show a, ToField a, FromField a) => Conversion (PropertyM IO) a e n +conversion + :: (Show e, Show n, Show a, Default a, ToField a, FromField a) + => Conversion (PropertyM IO) a e n conversion = Conversion { cView = view , cHistory = history @@ -24,8 +28,11 @@ conversion = Conversion , cMonadic = monadic } +stateId :: Int +stateId = 1 + view - :: (Show a, ToField a, FromField a, Show e, Show n) + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n -> PropertyM IO (Maybe (IndexView a)) view ix = do @@ -33,11 +40,11 @@ view ix = do case mix of Nothing -> pure Nothing Just ix' -> do - v <- M.run $ S.view ix' + v <- M.run $ S.view stateId ix' pure $ Just v notifications - :: (Show a, ToField a, FromField a, Show e, Show n) + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n -> PropertyM IO [n] notifications ix = do @@ -46,7 +53,7 @@ notifications ix = do liftIO $ S.getNotifications ix' history - :: (Show a, ToField a, FromField a, Show e, Show n) + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n -> PropertyM IO (Maybe [a]) history ix = do @@ -54,7 +61,7 @@ history ix = do case mix of Nothing -> pure Nothing Just ix' -> liftIO $ do - h <- S.getHistory ix' + h <- S.getHistory stateId ix' pure $ Just h monadic @@ -63,11 +70,11 @@ monadic monadic = monadicIO run - :: forall a e n. (Show a, ToField a, FromField a, Show e, Show n) + :: forall a e n. (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n - -> PropertyM IO (Maybe (SqliteIndex a e n)) + -> PropertyM IO (Maybe (SqliteIndex e n Int a)) run (Ix.New f depth acc) = do - sqliteIndex <- liftIO $ S.new findex fstore fload depth ":memory:" + sqliteIndex <- liftIO $ S.new fquery foninsert fstore depth ":memory:" case sqliteIndex of Nothing -> pure Nothing Just ix -> do @@ -76,18 +83,21 @@ run (Ix.New f depth acc) = do liftIO $ do execute_ c "DROP TABLE IF EXISTS index_property_tests" execute_ c "CREATE TABLE index_property_tests (id INTEGER PRIMARY KEY, accumulator INT)" - execute c "INSERT INTO index_property_tests (id, accumulator) VALUES (?, ?)" (1 :: Int, acc) + execute c "INSERT INTO index_property_tests (id, accumulator) VALUES (?, ?)" (stateId, acc) pure . Just $ ix where - findex :: a -> [e] -> (a, [n]) - findex a es = foldr convertIxF (a, []) es - fstore :: Connection -> a -> IO () - fstore c a = - execute c "UPDATE index_property_tests SET accumulator = ? WHERE id = ?" (a, 1 :: Int) - fload :: Connection -> IO a - fload c = do - [[a]] <- query c "SELECT (accumulator) FROM index_property_tests WHERE id = ?" (Only 1 :: Only Int) - pure a + fstore :: SqliteIndex e n Int a -> IO () + fstore ix@SplitIndex{siHandle} = do + currentStore <- fquery ix stateId [] + execute siHandle "UPDATE index_property_tests SET accumulator = ? WHERE id = ?" (currentStore, stateId) + fquery :: SqliteIndex e n Int a -> Int -> [e] -> IO a + fquery SplitIndex{siHandle, siBuffered} stateId' es = do + [[storedState]] <- query siHandle "SELECT (accumulator) FROM index_property_tests WHERE id = ?" (Only stateId') + pure . fst $ foldr convertIxF (storedState, []) (es ++ siBuffered) + foninsert :: e -> SqliteIndex e n Int a -> IO [n] + foninsert e ix@SplitIndex{siEvents} = do + currentState <- fquery ix stateId siEvents + pure $ catMaybes [snd $ f currentState e] convertIxF :: e -> (a, [n]) -> (a, [n]) convertIxF e (a, ns) = let (a', mn) = f a e From 5b3c58d3af7c9274bcf1c641195a303d99aa3594 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Tue, 10 May 2022 19:43:18 +0700 Subject: [PATCH 54/62] Switch from lists to sequences. --- hysterical-screams.cabal | 1 + package.yaml | 1 + src/Index.hs | 2 +- src/Index/Split.hs | 52 +++++++++++++++++++++------------------- src/Index/Sqlite.hs | 8 ++++--- test/Spec/Index.hs | 11 +++++---- test/Spec/Split.hs | 10 ++++---- test/Spec/Sqlite.hs | 10 ++++---- 8 files changed, 54 insertions(+), 41 deletions(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 7a37e837a1..b6bd1f4276 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -51,6 +51,7 @@ library build-depends: QuickCheck , base >=4.7 && <5 + , containers , data-default , quickspec , sqlite-simple diff --git a/package.yaml b/package.yaml index 927185d1fc..e6a100761c 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ dependencies: - quickspec - sqlite-simple - data-default +- containers library: source-dirs: src diff --git a/src/Index.hs b/src/Index.hs index 46b1d1dc05..2132620a02 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -107,7 +107,7 @@ view (Rewind n ix) = do v <- view ix if length h > n then Just $ v { ixSize = ixSize v - n - , ixView = head $ drop n h + , ixView = h !! max 0 n } else Nothing diff --git a/src/Index/Split.hs b/src/Index/Split.hs index f3a659aaae..e456f46505 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -12,20 +12,21 @@ module Index.Split , getNotifications ) where -import Data.List (tails) -import Data.Foldable (foldlM) +import Data.Foldable (foldlM) +import Data.Sequence (Seq(..), ViewL(..), ViewR(..)) +import qualified Data.Sequence as Seq -import Index (IndexView (..)) +import Index (IndexView (..)) data SplitIndex m h e n q r = SplitIndex { siHandle :: h - , siEvents :: [e] - , siBuffered :: [e] + , siEvents :: Seq e + , siBuffered :: Seq e , siNotifications :: [n] , siDepth :: Int -- TODO: What about txs? , siStore :: SplitIndex m h e n q r -> m () - , siQuery :: SplitIndex m h e n q r -> q -> [e] -> m r + , siQuery :: SplitIndex m h e n q r -> q -> Seq e -> m r , siOnInsert :: e -> SplitIndex m h e n q r -> m [n] } @@ -34,11 +35,11 @@ instance (Show r, Show e) => Show (SplitIndex m h e n q r) where "{ Events: " <> show siEvents <> " Buffered: " <> show siBuffered <> " }" storeEventsThreshold :: Int -storeEventsThreshold = 3 +storeEventsThreshold = 2 new :: Monad m - => (SplitIndex m h e n q r -> q -> [e] -> m r) + => (SplitIndex m h e n q r -> q -> Seq e -> m r) -> (e -> SplitIndex m h e n q r -> m [n]) -> (SplitIndex m h e n q r -> m ()) -> Int @@ -48,8 +49,8 @@ new fquery foninsert fstore depth handle | depth <= 0 = pure Nothing | otherwise = pure . Just $ SplitIndex { siHandle = handle - , siEvents = [] - , siBuffered = [] + , siEvents = Seq.empty + , siBuffered = Seq.empty , siNotifications = [] , siDepth = depth , siStore = fstore @@ -64,34 +65,35 @@ insert -> m (SplitIndex m h e n q r) insert e ix@SplitIndex{siOnInsert, siNotifications, siEvents, siDepth, siBuffered} | siDepth /= 1 = do - let (siEvents', siBuffered') + let topEvents :> lastEvent = Seq.viewr siEvents + (siEvents', siBuffered') = if size ix == siDepth - then ( e : take (siDepth - 2) siEvents - , last siEvents : siBuffered ) - else ( e : siEvents, siBuffered ) + then ( e :<| topEvents + , lastEvent :<| siBuffered ) + else ( e :<| siEvents, siBuffered ) ns <- siOnInsert e ix let ix' = ix { siEvents = siEvents' , siBuffered = siBuffered' , siNotifications = ns ++ siNotifications } - if length siBuffered' > siDepth * storeEventsThreshold + if Seq.length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' -- Special casing siDepth == 1 => siEvents is unused. | otherwise = do - let siBuffered' = e : siBuffered + let siBuffered' = e :<| siBuffered ns <- siOnInsert e ix - let ix' = ix { siBuffered = e : siBuffered + let ix' = ix { siBuffered = siBuffered' , siNotifications = ns ++ siNotifications } - if length siBuffered' > siDepth * storeEventsThreshold + if Seq.length siBuffered' > siDepth * storeEventsThreshold then mergeEvents ix' else pure ix' mergeEvents :: Monad m => SplitIndex m h e n q r -> m (SplitIndex m h e n q r) mergeEvents ix@SplitIndex{siStore} = do _ <- siStore ix - pure $ ix { siBuffered = [] } + pure $ ix { siBuffered = Seq.empty } insertL :: Monad m => [e] -> SplitIndex m h e n q r -> m (SplitIndex m h e n q r) insertL es ix = foldlM (flip insert) ix es @@ -103,20 +105,20 @@ size SplitIndex {siEvents} = rewind :: Int -> SplitIndex m h e n q r -> Maybe (SplitIndex m h e n q r) rewind n ix@SplitIndex {siEvents} - | size ix > n = Just $ ix { siEvents = drop n siEvents } + | size ix > n = Just $ ix { siEvents = Seq.drop n siEvents } | otherwise = Nothing -view :: Monad m => q -> SplitIndex m h e n q r -> m (IndexView r) +view :: (Monad m, MonadFail m) => q -> SplitIndex m h e n q r -> m (IndexView r) view query ix@SplitIndex{siDepth} = do - h <- getHistory query ix + h :< _ <- Seq.viewl <$> getHistory query ix pure $ IndexView { ixDepth = siDepth - , ixView = head h + , ixView = h , ixSize = size ix } getNotifications :: Monad m => SplitIndex m h e n q r -> m [n] getNotifications SplitIndex{siNotifications} = pure siNotifications -getHistory :: forall m h e n q r. Monad m => q -> SplitIndex m h e n q r -> m [r] +getHistory :: forall m h e n q r. Monad m => q -> SplitIndex m h e n q r -> m (Seq r) getHistory query ix@SplitIndex{siQuery, siEvents} = - mapM (siQuery ix query) $ tails siEvents + traverse (siQuery ix query) $ Seq.tails siEvents diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index 022001f316..831da2cb81 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -13,6 +13,8 @@ module Index.Sqlite ) where import Database.SQLite.Simple (Connection, open) +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq import Index.Split (SplitIndex (..)) import qualified Index.Split as S @@ -20,7 +22,7 @@ import qualified Index.Split as S type SqliteIndex e n q r = SplitIndex IO Connection e n q r new - :: (SqliteIndex e n q r -> q -> [e] -> IO r) + :: (SqliteIndex e n q r -> q -> Seq e -> IO r) -> (e -> SqliteIndex e n q r -> IO [n]) -> (SqliteIndex e n q r -> IO ()) -> Int @@ -32,8 +34,8 @@ new fquery foninsert fstore depth db connection <- open db pure . Just $ SplitIndex { siHandle = connection - , siEvents = [] - , siBuffered = [] + , siEvents = Seq.empty + , siBuffered = Seq.empty , siNotifications = [] , siDepth = depth , siStore = fstore diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 484a902565..4e58a32241 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -2,6 +2,8 @@ module Spec.Index where import Data.Functor.Identity (Identity, runIdentity) import Data.List (foldl', isPrefixOf, scanl') +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq import Data.Maybe (fromJust, isJust, isNothing, mapMaybe) import QuickSpec import Test.QuickCheck.Monadic @@ -11,7 +13,7 @@ import Index data Conversion m a e n = Conversion { cView :: Index a e n -> m (Maybe (IndexView a)) - , cHistory :: Index a e n -> m (Maybe [a]) + , cHistory :: Index a e n -> m (Maybe (Seq a)) , cNotifications :: Index a e n -> m [n] , cMonadic :: m Property -> Property } @@ -19,7 +21,8 @@ data Conversion m a e n = Conversion conversion :: Conversion Identity a e n conversion = Conversion { cView = pure . view - , cHistory = pure . getHistory + , cHistory = + \ix -> pure $ Seq.fromList <$> getHistory ix , cNotifications = pure . fromJust . getNotifications , cMonadic = runIdentity } @@ -50,7 +53,7 @@ prop_observeNew c f a = , ixView = a , ixSize = 1 }) - && h == Just [a] + && h == Just (Seq.singleton a) -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) @@ -105,7 +108,7 @@ prop_insertRewindInverse c (ObservedBuilder ix) = \bs -> monadic (cMonadic c) $ do let ix' = rewind (length bs) $ insertL bs ix Just v' <- run $ cView c ix - h <- take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) + h <- Seq.take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) h' <- fromJust <$> run (cHistory c ix') assert $ h == h' diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index 3fd6586fd7..c14346af63 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -4,6 +4,8 @@ import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) import Control.Monad.IO.Class (liftIO) import Data.Default import Data.Maybe (catMaybes) +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) @@ -46,7 +48,7 @@ notifications ix = do history :: (Show s, Show e, Show n, Default s) => Index s e n - -> PropertyM IO (Maybe [s]) + -> PropertyM IO (Maybe (Seq s)) history ix = do mix <- run ix case mix of @@ -71,13 +73,13 @@ run (Ix.New f depth store) = do mstore <- newMVar store S.new fquery foninsert fstore depth mstore where - fquery :: SplitIndex IO (MVar s) e n () s -> () -> [e] -> IO s + fquery :: SplitIndex IO (MVar s) e n () s -> () -> Seq e -> IO s fquery SplitIndex{siHandle, siBuffered} () es = do oldState <- readMVar siHandle - pure . fst $ foldr convertIxF (oldState, []) (es ++ siBuffered) + pure . fst $ foldr convertIxF (oldState, []) (es >< siBuffered) fstore :: SplitIndex IO (MVar s) e n () s -> IO () fstore ix@SplitIndex{siHandle} = do - newState <- fquery ix () [] + newState <- fquery ix () Seq.empty _ <- swapMVar siHandle newState pure () foninsert :: e -> SplitIndex IO (MVar s) e n () s -> IO [n] diff --git a/test/Spec/Sqlite.hs b/test/Spec/Sqlite.hs index 5d65b3c838..df782037e7 100644 --- a/test/Spec/Sqlite.hs +++ b/test/Spec/Sqlite.hs @@ -3,6 +3,8 @@ module Spec.Sqlite where import Control.Monad.IO.Class (liftIO) import Data.Default import Data.Maybe (catMaybes) +import Data.Sequence (Seq, (><)) +import qualified Data.Sequence as Seq import Database.SQLite.Simple (Only (..), execute, execute_, query) import Database.SQLite.Simple.FromField @@ -55,7 +57,7 @@ notifications ix = do history :: (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n - -> PropertyM IO (Maybe [a]) + -> PropertyM IO (Maybe (Seq a)) history ix = do mix <- run ix case mix of @@ -88,12 +90,12 @@ run (Ix.New f depth acc) = do where fstore :: SqliteIndex e n Int a -> IO () fstore ix@SplitIndex{siHandle} = do - currentStore <- fquery ix stateId [] + currentStore <- fquery ix stateId Seq.empty execute siHandle "UPDATE index_property_tests SET accumulator = ? WHERE id = ?" (currentStore, stateId) - fquery :: SqliteIndex e n Int a -> Int -> [e] -> IO a + fquery :: SqliteIndex e n Int a -> Int -> Seq e -> IO a fquery SplitIndex{siHandle, siBuffered} stateId' es = do [[storedState]] <- query siHandle "SELECT (accumulator) FROM index_property_tests WHERE id = ?" (Only stateId') - pure . fst $ foldr convertIxF (storedState, []) (es ++ siBuffered) + pure . fst $ foldr convertIxF (storedState, []) (es >< siBuffered) foninsert :: e -> SqliteIndex e n Int a -> IO [n] foninsert e ix@SplitIndex{siEvents} = do currentState <- fquery ix stateId siEvents From 01fcf5cd9e8b89c1089dc4bb753bf007aca7f8d0 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 11 May 2022 22:13:45 +0700 Subject: [PATCH 55/62] Add strictness. --- src/Index/Split.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Index/Split.hs b/src/Index/Split.hs index e456f46505..322609c9f1 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Strict #-} + module Index.Split ( -- * API SplitIndex(..) @@ -65,11 +67,11 @@ insert -> m (SplitIndex m h e n q r) insert e ix@SplitIndex{siOnInsert, siNotifications, siEvents, siDepth, siBuffered} | siDepth /= 1 = do - let topEvents :> lastEvent = Seq.viewr siEvents - (siEvents', siBuffered') + let (siEvents', siBuffered') = if size ix == siDepth - then ( e :<| topEvents - , lastEvent :<| siBuffered ) + then let topEvents :> lastEvent = Seq.viewr siEvents + in ( e :<| topEvents + , lastEvent :<| siBuffered ) else ( e :<| siEvents, siBuffered ) ns <- siOnInsert e ix let ix' = ix { siEvents = siEvents' From 8ae0ef07d81d7806f0bdacb900931f86b76022a4 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 13 May 2022 12:03:42 +0700 Subject: [PATCH 56/62] Run less tests. --- hysterical-screams.cabal | 1 + package.yaml | 1 + src/Index/VSplit.hs | 3 +++ test/Spec.hs | 12 ++++++------ 4 files changed, 11 insertions(+), 6 deletions(-) create mode 100644 src/Index/VSplit.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index b6bd1f4276..3f9730bf32 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -31,6 +31,7 @@ library Index Index.Split Index.Sqlite + Index.VSplit other-modules: Paths_hysterical_screams hs-source-dirs: diff --git a/package.yaml b/package.yaml index e6a100761c..c43c00fcca 100644 --- a/package.yaml +++ b/package.yaml @@ -41,6 +41,7 @@ dependencies: - sqlite-simple - data-default - containers +- vector library: source-dirs: src diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs new file mode 100644 index 0000000000..ecab29062a --- /dev/null +++ b/src/Index/VSplit.hs @@ -0,0 +1,3 @@ +module Index.VSplit + ( + ) where diff --git a/test/Spec.hs b/test/Spec.hs index 90968cc97e..120b39dbb0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -35,11 +35,11 @@ siProperties = testGroup "Split index" , testProperty "Rewind: Connection with `ixDepth`" $ withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int S.conversion , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int S.conversion + withMaxSuccess 1000 $ Ix.prop_insertRewindInverse @Int @Int @Int S.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int S.conversion + withMaxSuccess 1000 $ Ix.prop_observeInsert @Int @Int @Int S.conversion , testProperty "Notifications are accumulated as the fold runs" $ - withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int S.conversion + withMaxSuccess 1000 $ Ix.prop_observeNotifications @Int @Int @Int S.conversion , testProperty "Notifications are not affected by rewind" $ withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int S.conversion ] @@ -53,11 +53,11 @@ sqProperties = testGroup "Sqlite index" , testProperty "Rewind: Connection with `ixDepth`" $ withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int Sqlite.conversion , testProperty "Relationship between Insert/Rewind" $ - withMaxSuccess 10000 $ Ix.prop_insertRewindInverse @Int @Int @Int Sqlite.conversion + withMaxSuccess 1000 $ Ix.prop_insertRewindInverse @Int @Int @Int Sqlite.conversion , testProperty "Insert is folding the structure" $ - withMaxSuccess 10000 $ Ix.prop_observeInsert @Int @Int @Int Sqlite.conversion + withMaxSuccess 1000 $ Ix.prop_observeInsert @Int @Int @Int Sqlite.conversion , testProperty "Notifications are accumulated as the fold runs" $ - withMaxSuccess 10000 $ Ix.prop_observeNotifications @Int @Int @Int Sqlite.conversion + withMaxSuccess 1000 $ Ix.prop_observeNotifications @Int @Int @Int Sqlite.conversion , testProperty "Notifications are not affected by rewind" $ withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int Sqlite.conversion ] From b2cbd58e7fa5720456d386ad6582ebc7aaada596 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Fri, 13 May 2022 18:09:32 +0700 Subject: [PATCH 57/62] Initial implementation of split index based on the vector library. --- hysterical-screams.cabal | 6 + package.yaml | 2 + src/Index/VSplit.hs | 234 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 241 insertions(+), 1 deletion(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 3f9730bf32..a4ac61972d 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -54,8 +54,11 @@ library , base >=4.7 && <5 , containers , data-default + , lens + , primitive , quickspec , sqlite-simple + , vector default-language: Haskell2010 test-suite hysterical-screams-test @@ -87,8 +90,11 @@ test-suite hysterical-screams-test , containers , data-default , hysterical-screams + , lens + , primitive , quickspec , sqlite-simple , tasty , tasty-quickcheck + , vector default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index c43c00fcca..8c4a5be234 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,8 @@ dependencies: - data-default - containers - vector +- primitive +- lens library: source-dirs: src diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index ecab29062a..96b0fc3110 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -1,3 +1,235 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} + module Index.VSplit - ( + ( SplitIndex(..) + , new + , insert + , insertL + , size + , rewind + -- * Accessors to SplitIndex + , handle + , storage + , notifications + , store + , query + , onInsert + -- * Storage + , Storage + , getBuffer + , getEvents + -- * Observations + , getNotifications + , getHistory + , view ) where + +import Control.Lens.Operators +import qualified Control.Lens.TH as Lens +import Control.Monad.Primitive (PrimState, PrimMonad) +import Data.List (tails) +import Data.Foldable (toList, foldlM) +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +import Index (IndexView(..)) + +data Storage v m e = Storage + { _events :: (VG.Mutable v) (PrimState m) e + , _cursor :: Int + , _stSize :: Int + , _k :: Int + } +$(Lens.makeLenses ''Storage) + +maxSize + :: VGM.MVector (VG.Mutable v) e + => Storage v m e + -> Int +maxSize store = store ^. events & VGM.length + +bufferSize + :: VGM.MVector (VG.Mutable v) e + => Storage v m e + -> Int +bufferSize store = maxSize store - store ^. k + +isStorageFull + :: VGM.MVector (VG.Mutable v) e + => Storage v m e + -> Bool +isStorageFull store = maxSize store == store ^. stSize + +getBuffer + :: forall v m e. + VGM.MVector (VG.Mutable v) e + => Foldable (VG.Mutable v (PrimState m)) + => Storage v m e + -> [e] +getBuffer storage = + getInterval (storage ^. cursor) (bufferSize storage) storage + +getEvents + :: forall v m e. + VGM.MVector (VG.Mutable v) e + => Foldable (VG.Mutable v (PrimState m)) + => Storage v m e + -> [e] +getEvents storage = + let c = storage ^. cursor + k' = storage ^. k + in getInterval (c - k') c storage + +getInterval + :: forall v m e. + VGM.MVector (VG.Mutable v) e + => Foldable (VG.Mutable v (PrimState m)) + => Int + -> Int + -> Storage v m e + -> [e] +getInterval start size' store + -- k overflows to the begining + | start < 0 = + getInterval (maxSize store + start) (- start) store + ++ getInterval 0 (size' + start) store + -- buffer overflows to the start + | start + size' >= maxSize store = + let endSize = start + size' `rem` maxSize store + startSize = size' - endSize + in getInterval start startSize store + ++ getInterval 0 endSize store + -- normal case + | otherwise = toList $ VGM.slice start size' (store ^. events) + +data SplitIndex m h v e n q r = SplitIndex + { _handle :: h + , _storage :: Storage v m e + , _notifications :: [n] + , _store :: SplitIndex m h v e n q r -> m () + , _query :: SplitIndex m h v e n q r -> q -> [e] -> m r + , _onInsert :: SplitIndex m h v e n q r -> e -> m [n] + } +$(Lens.makeLenses ''SplitIndex) + +new + :: Monad m + => VGM.MVector (VG.Mutable v) e + => (SplitIndex m h v e n q r -> q -> [e] -> m r) + -> (SplitIndex m h v e n q r -> m ()) + -> (SplitIndex m h v e n q r -> e -> m [n]) + -> Int + -> h + -> (VG.Mutable v) (PrimState m) e + -> m (Maybe (SplitIndex m h v e n q r)) +new query' store' onInsert' k' handle' vector + | k' <= 0 = pure Nothing + -- The vector has to accomodate at least k + 1 elements. + | k' >= VGM.length vector = pure Nothing + | otherwise = pure . Just $ SplitIndex + { _handle = handle' + , _storage = Storage { _events = vector + , _cursor = 0 + , _stSize = 0 + , _k = k' + } + , _notifications = [] + , _store = store' + , _query = query' + , _onInsert = onInsert' + } + +insert + :: forall m h v e n q r. + Monad m + => PrimMonad m + => VGM.MVector (VG.Mutable v) e + => e + -> SplitIndex m h v e n q r + -> m (SplitIndex m h v e n q r) +insert e ix = do + -- o | ix ^. storage . k /= 1 = do + let es = ix ^. storage . events + c = ix ^. storage . cursor + VGM.unsafeWrite es c e + ns <- (ix ^. onInsert) ix e + let ix' = (storage . stSize) %~ (+1) $ + (storage . cursor) %~ (+1) $ + notifications %~ (++ns) $ ix + if isStorageFull (ix' ^. storage) + then storeEvents ix' + else pure ix' + -- o | otherwise = undefined + +storeEvents + :: Monad m + => VGM.MVector (VG.Mutable v) e + => SplitIndex m h v e n q r + -> m (SplitIndex m h v e n q r) +storeEvents ix = do + -- TODO: Change store to store :: h -> [e] -> m () (?) + ix & ix ^. store + let sz = bufferSize $ ix ^. storage + pure $ + (storage . stSize) %~ (\s -> s - sz) $ ix + +insertL + :: Monad m + => PrimMonad m + => VGM.MVector (VG.Mutable v) e + => [e] + -> SplitIndex m h v e n q r + -> m (SplitIndex m h v e n q r) +insertL es ix = foldlM (flip insert) ix es + +size + :: SplitIndex m h v e n q r + -> Int +size ix = min (ix ^. storage . k) + (ix ^. storage . stSize) + +rewind + :: VGM.MVector (VG.Mutable v) e + => Int + -> SplitIndex m h v e n q r + -> Maybe (SplitIndex m h v e n q r) +rewind n ix + | size ix > n = Just $ + (storage . cursor) %~ (\c -> adjust (c - n)) $ ix + | otherwise = Nothing + where + adjust :: Int -> Int + adjust p + | p < 0 = maxSize (ix ^. storage) - p + | otherwise = p + +getNotifications + :: SplitIndex m h v e n q r + -> [n] +getNotifications ix = ix ^. notifications + +getHistory + :: Monad m + => VGM.MVector (VG.Mutable v) e + => Foldable (VG.Mutable v (PrimState m)) + => SplitIndex m h v e n q r + -> q + -> m [r] +getHistory ix q = do + let es = getEvents (ix ^. storage) + traverse ((ix ^. query) ix q) $ tails es + +view + :: Monad m + => VGM.MVector (VG.Mutable v) e + => Foldable (VG.Mutable v (PrimState m)) + => SplitIndex m h v e n q r + -> q + -> m (IndexView r) +view ix q = do + hs <- getHistory ix q + pure $ IndexView { ixDepth = ix ^. storage . k + , ixView = head hs + , ixSize = size ix + } From 91e69f3f1954544a111f80a76a8a7969ff1a0906 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Sat, 14 May 2022 10:33:05 +0700 Subject: [PATCH 58/62] Added boxed and unboxed variants of new. --- src/Index/VSplit.hs | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index 96b0fc3110..f930113309 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -4,11 +4,13 @@ module Index.VSplit ( SplitIndex(..) , new + , newBoxed + , newUnboxed , insert , insertL , size , rewind - -- * Accessors to SplitIndex + -- * Accessors , handle , storage , notifications @@ -32,6 +34,8 @@ import Data.List (tails) import Data.Foldable (toList, foldlM) import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU import Index (IndexView(..)) @@ -140,6 +144,45 @@ new query' store' onInsert' k' handle' vector , _onInsert = onInsert' } +type BoxedIndex m h e n q r = + SplitIndex m h V.Vector e n q r + +newBoxed + :: Monad m + => PrimMonad m + => (BoxedIndex m h e n q r -> q -> [e] -> m r) + -> (BoxedIndex m h e n q r -> m ()) + -> (BoxedIndex m h e n q r -> e -> m [n]) + -> Int + -> Int + -> h + -> m (Maybe (BoxedIndex m h e n q r)) +newBoxed query' store' onInsert' k' size' handle' + | size' > 0 = pure Nothing + | otherwise = do + v <- VGM.new (k' + size') + new query' store' onInsert' k' handle' v + +type UnboxedIndex m h e n q r = + SplitIndex m h VU.Vector e n q r + +newUnboxed + :: Monad m + => PrimMonad m + => VGM.MVector VU.MVector e + => (UnboxedIndex m h e n q r -> q -> [e] -> m r) + -> (UnboxedIndex m h e n q r -> m ()) + -> (UnboxedIndex m h e n q r -> e -> m [n]) + -> Int + -> Int + -> h + -> m (Maybe (UnboxedIndex m h e n q r)) +newUnboxed query' store' onInsert' k' size' handle' + | size' > 0 = pure Nothing + | otherwise = do + v <- VGM.new (k' + size') + new query' store' onInsert' k' handle' v + insert :: forall m h v e n q r. Monad m From c20da703bde82778e9a34c497e20327a33f3e464 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Wed, 18 May 2022 23:51:45 +0700 Subject: [PATCH 59/62] Add vector based indices. --- hysterical-screams.cabal | 1 + src/Index/Split.hs | 13 +++-- src/Index/VSplit.hs | 112 ++++++++++++++++++++------------------ test/Spec.hs | 21 ++++++- test/Spec/Index.hs | 14 ++--- test/Spec/Split.hs | 2 +- test/Spec/Sqlite.hs | 2 +- test/Spec/VSplit.hs | 115 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 212 insertions(+), 68 deletions(-) create mode 100644 test/Spec/VSplit.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index a4ac61972d..67af551ea8 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -68,6 +68,7 @@ test-suite hysterical-screams-test Spec.Index Spec.Split Spec.Sqlite + Spec.VSplit Paths_hysterical_screams hs-source-dirs: test diff --git a/src/Index/Split.hs b/src/Index/Split.hs index 322609c9f1..cf7ed8e0bc 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -14,8 +14,8 @@ module Index.Split , getNotifications ) where -import Data.Foldable (foldlM) -import Data.Sequence (Seq(..), ViewL(..), ViewR(..)) +import Data.Foldable (foldlM, toList) +import Data.Sequence (Seq (..), ViewR (..)) import qualified Data.Sequence as Seq import Index (IndexView (..)) @@ -112,7 +112,7 @@ rewind n ix@SplitIndex {siEvents} view :: (Monad m, MonadFail m) => q -> SplitIndex m h e n q r -> m (IndexView r) view query ix@SplitIndex{siDepth} = do - h :< _ <- Seq.viewl <$> getHistory query ix + h : _ <- getHistory query ix pure $ IndexView { ixDepth = siDepth , ixView = h , ixSize = size ix @@ -121,6 +121,7 @@ view query ix@SplitIndex{siDepth} = do getNotifications :: Monad m => SplitIndex m h e n q r -> m [n] getNotifications SplitIndex{siNotifications} = pure siNotifications -getHistory :: forall m h e n q r. Monad m => q -> SplitIndex m h e n q r -> m (Seq r) -getHistory query ix@SplitIndex{siQuery, siEvents} = - traverse (siQuery ix query) $ Seq.tails siEvents +getHistory :: forall m h e n q r. Monad m => q -> SplitIndex m h e n q r -> m [r] +getHistory query ix@SplitIndex{siQuery, siEvents} = do + xs <- traverse (siQuery ix query) $ Seq.tails siEvents + pure $ toList xs diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index f930113309..be45c5066d 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -30,8 +30,8 @@ module Index.VSplit import Control.Lens.Operators import qualified Control.Lens.TH as Lens import Control.Monad.Primitive (PrimState, PrimMonad) +import Data.Foldable (foldlM) import Data.List (tails) -import Data.Foldable (toList, foldlM) import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM import qualified Data.Vector as V @@ -42,7 +42,8 @@ import Index (IndexView(..)) data Storage v m e = Storage { _events :: (VG.Mutable v) (PrimState m) e , _cursor :: Int - , _stSize :: Int + , _eSize :: Int + , _bSize :: Int , _k :: Int } $(Lens.makeLenses ''Storage) @@ -53,59 +54,59 @@ maxSize -> Int maxSize store = store ^. events & VGM.length -bufferSize - :: VGM.MVector (VG.Mutable v) e - => Storage v m e - -> Int -bufferSize store = maxSize store - store ^. k - isStorageFull :: VGM.MVector (VG.Mutable v) e => Storage v m e -> Bool -isStorageFull store = maxSize store == store ^. stSize +isStorageFull store = maxSize store == store ^. eSize + store ^. bSize getBuffer :: forall v m e. VGM.MVector (VG.Mutable v) e - => Foldable (VG.Mutable v (PrimState m)) + => PrimMonad m + => Show e => Storage v m e - -> [e] -getBuffer storage = - getInterval (storage ^. cursor) (bufferSize storage) storage + -> m [e] +getBuffer store = + let bufferEnd = store ^. cursor - store ^. eSize + bufferStart = bufferEnd - store ^. bSize + in reverse <$> getInterval bufferStart (store ^. bSize) store getEvents :: forall v m e. VGM.MVector (VG.Mutable v) e - => Foldable (VG.Mutable v (PrimState m)) + => PrimMonad m + => Show e => Storage v m e - -> [e] -getEvents storage = - let c = storage ^. cursor - k' = storage ^. k - in getInterval (c - k') c storage + -> m [e] +getEvents store = + let c = store ^. cursor + esz = store ^. eSize + in reverse <$> getInterval (c - esz) esz store getInterval :: forall v m e. VGM.MVector (VG.Mutable v) e - => Foldable (VG.Mutable v (PrimState m)) + => PrimMonad m + => Show e => Int -> Int -> Storage v m e - -> [e] + -> m [e] getInterval start size' store - -- k overflows to the begining - | start < 0 = - getInterval (maxSize store + start) (- start) store - ++ getInterval 0 (size' + start) store + | size' == 0 = pure [] + -- k underflows to the begining + | start < 0 = do + getInterval (maxSize store + start) size' store -- buffer overflows to the start - | start + size' >= maxSize store = - let endSize = start + size' `rem` maxSize store + | start + size' > maxSize store = + let endSize = (start + size') `rem` maxSize store startSize = size' - endSize - in getInterval start startSize store - ++ getInterval 0 endSize store + in (++) <$> getInterval start startSize store + <*> getInterval 0 endSize store -- normal case - | otherwise = toList $ VGM.slice start size' (store ^. events) + | otherwise = do + VGM.foldr' (:) [] $ VGM.slice start size' (store ^. events) data SplitIndex m h v e n q r = SplitIndex { _handle :: h @@ -128,14 +129,15 @@ new -> (VG.Mutable v) (PrimState m) e -> m (Maybe (SplitIndex m h v e n q r)) new query' store' onInsert' k' handle' vector - | k' <= 0 = pure Nothing + | k' < 0 = pure Nothing -- The vector has to accomodate at least k + 1 elements. | k' >= VGM.length vector = pure Nothing | otherwise = pure . Just $ SplitIndex { _handle = handle' , _storage = Storage { _events = vector , _cursor = 0 - , _stSize = 0 + , _eSize = 0 + , _bSize = 0 , _k = k' } , _notifications = [] @@ -158,7 +160,7 @@ newBoxed -> h -> m (Maybe (BoxedIndex m h e n q r)) newBoxed query' store' onInsert' k' size' handle' - | size' > 0 = pure Nothing + | k' < 0 || size' <= 0 = pure Nothing | otherwise = do v <- VGM.new (k' + size') new query' store' onInsert' k' handle' v @@ -178,7 +180,7 @@ newUnboxed -> h -> m (Maybe (UnboxedIndex m h e n q r)) newUnboxed query' store' onInsert' k' size' handle' - | size' > 0 = pure Nothing + | k' < 0 || size' <= 0 = pure Nothing | otherwise = do v <- VGM.new (k' + size') new query' store' onInsert' k' handle' v @@ -192,18 +194,25 @@ insert -> SplitIndex m h v e n q r -> m (SplitIndex m h v e n q r) insert e ix = do - -- o | ix ^. storage . k /= 1 = do let es = ix ^. storage . events c = ix ^. storage . cursor + vs = VGM.length es VGM.unsafeWrite es c e ns <- (ix ^. onInsert) ix e - let ix' = (storage . stSize) %~ (+1) $ - (storage . cursor) %~ (+1) $ - notifications %~ (++ns) $ ix + let ix' = storage %~ updateSizes $ + (storage . cursor) %~ (\c' -> (c' + 1) `rem` vs) $ + notifications %~ (ns++) $ ix if isStorageFull (ix' ^. storage) then storeEvents ix' else pure ix' - -- o | otherwise = undefined + + where + updateSizes :: Storage v m e -> Storage v m e + updateSizes st = + -- Event sizes increase by one upto K + eSize %~ (\sz -> min (sz + 1) (st ^. k)) $ + -- The buffer only grows when the event buffer is full + bSize %~ (\sz -> if st ^. eSize == st ^. k then sz + 1 else sz) $ st storeEvents :: Monad m @@ -213,9 +222,8 @@ storeEvents storeEvents ix = do -- TODO: Change store to store :: h -> [e] -> m () (?) ix & ix ^. store - let sz = bufferSize $ ix ^. storage pure $ - (storage . stSize) %~ (\s -> s - sz) $ ix + (storage . bSize) .~ 0 $ ix insertL :: Monad m @@ -229,8 +237,7 @@ insertL es ix = foldlM (flip insert) ix es size :: SplitIndex m h v e n q r -> Int -size ix = min (ix ^. storage . k) - (ix ^. storage . stSize) +size ix = 1 + (ix ^. storage . eSize) rewind :: VGM.MVector (VG.Mutable v) e @@ -238,13 +245,14 @@ rewind -> SplitIndex m h v e n q r -> Maybe (SplitIndex m h v e n q r) rewind n ix - | size ix > n = Just $ - (storage . cursor) %~ (\c -> adjust (c - n)) $ ix + | ix ^. storage . eSize >= n = Just $ + (storage . cursor) %~ (\c -> adjust (c - n)) $ + (storage . eSize ) %~ (\sz -> sz - n) $ ix | otherwise = Nothing where adjust :: Int -> Int adjust p - | p < 0 = maxSize (ix ^. storage) - p + | p < 0 = maxSize (ix ^. storage) + p | otherwise = p getNotifications @@ -253,26 +261,26 @@ getNotifications getNotifications ix = ix ^. notifications getHistory - :: Monad m + :: PrimMonad m => VGM.MVector (VG.Mutable v) e - => Foldable (VG.Mutable v (PrimState m)) + => Show e => SplitIndex m h v e n q r -> q -> m [r] getHistory ix q = do - let es = getEvents (ix ^. storage) + es <- getEvents (ix ^. storage) traverse ((ix ^. query) ix q) $ tails es view - :: Monad m + :: PrimMonad m => VGM.MVector (VG.Mutable v) e - => Foldable (VG.Mutable v (PrimState m)) + => Show e => SplitIndex m h v e n q r -> q -> m (IndexView r) view ix q = do hs <- getHistory ix q - pure $ IndexView { ixDepth = ix ^. storage . k + pure $ IndexView { ixDepth = ix ^. storage . k + 1 , ixView = head hs , ixSize = size ix } diff --git a/test/Spec.hs b/test/Spec.hs index 120b39dbb0..7c90111c4a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,9 +4,10 @@ import Test.Tasty.QuickCheck import qualified Spec.Index as Ix import qualified Spec.Split as S import qualified Spec.Sqlite as Sqlite +import qualified Spec.VSplit as V tests :: TestTree -tests = testGroup "Index" [ixProperties, siProperties, sqProperties] +tests = testGroup "Index" [ixProperties, siProperties, sqProperties, viProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" @@ -62,6 +63,24 @@ sqProperties = testGroup "Sqlite index" withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int Sqlite.conversion ] +viProperties :: TestTree +viProperties = testGroup "Vector index" + [ testProperty "New: Positive or non-positive depth" $ + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int V.conversion + , testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int V.conversion + , testProperty "Rewind: Connection with `ixDepth`" $ + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int V.conversion + , testProperty "Relationship between Insert/Rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindInverse @Int @Int @Int V.conversion + , testProperty "Insert is folding the structure" $ + withMaxSuccess 1000 $ Ix.prop_observeInsert @Int @Int @Int V.conversion + , testProperty "Notifications are accumulated as the fold runs" $ + withMaxSuccess 1000 $ Ix.prop_observeNotifications @Int @Int @Int V.conversion + , testProperty "Notifications are not affected by rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int V.conversion + ] + main :: IO () main = do -- quickSpec ixSignature diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index 4e58a32241..f6338542e2 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -2,8 +2,6 @@ module Spec.Index where import Data.Functor.Identity (Identity, runIdentity) import Data.List (foldl', isPrefixOf, scanl') -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq import Data.Maybe (fromJust, isJust, isNothing, mapMaybe) import QuickSpec import Test.QuickCheck.Monadic @@ -13,7 +11,7 @@ import Index data Conversion m a e n = Conversion { cView :: Index a e n -> m (Maybe (IndexView a)) - , cHistory :: Index a e n -> m (Maybe (Seq a)) + , cHistory :: Index a e n -> m (Maybe [a]) , cNotifications :: Index a e n -> m [n] , cMonadic :: m Property -> Property } @@ -21,14 +19,14 @@ data Conversion m a e n = Conversion conversion :: Conversion Identity a e n conversion = Conversion { cView = pure . view - , cHistory = - \ix -> pure $ Seq.fromList <$> getHistory ix + , cHistory = pure . getHistory , cNotifications = pure . fromJust . getNotifications , cMonadic = runIdentity } prop_observeNew :: forall e a n m. (Eq a, Monad m) + => Show a => Conversion m a e n -> Fun (a, e) (a, Maybe n) -> a @@ -53,7 +51,7 @@ prop_observeNew c f a = , ixView = a , ixSize = 1 }) - && h == Just (Seq.singleton a) + && h == Just [a] -- | Properties of the connection between rewind and depth -- Note: Cannot rewind if (ixDepth ix == 1) @@ -83,6 +81,7 @@ prop_rewindDepth c (ObservedBuilder ix) = -- | Property that validates the HF data structure. prop_sizeLEDepth :: forall e a n m. (Monad m) + => Show a => Conversion m a e n -> ObservedBuilder a e n -> Property @@ -108,7 +107,8 @@ prop_insertRewindInverse c (ObservedBuilder ix) = \bs -> monadic (cMonadic c) $ do let ix' = rewind (length bs) $ insertL bs ix Just v' <- run $ cView c ix - h <- Seq.take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) + h <- take (ixDepth v' - length bs) . fromJust <$> run (cHistory c ix) + -- h <- fromJust <$> run (cHistory c ix) h' <- fromJust <$> run (cHistory c ix') assert $ h == h' diff --git a/test/Spec/Split.hs b/test/Spec/Split.hs index c14346af63..4d28b3af0f 100644 --- a/test/Spec/Split.hs +++ b/test/Spec/Split.hs @@ -48,7 +48,7 @@ notifications ix = do history :: (Show s, Show e, Show n, Default s) => Index s e n - -> PropertyM IO (Maybe (Seq s)) + -> PropertyM IO (Maybe [s]) history ix = do mix <- run ix case mix of diff --git a/test/Spec/Sqlite.hs b/test/Spec/Sqlite.hs index df782037e7..8226421473 100644 --- a/test/Spec/Sqlite.hs +++ b/test/Spec/Sqlite.hs @@ -57,7 +57,7 @@ notifications ix = do history :: (Show a, Default a, ToField a, FromField a, Show e, Show n) => Index a e n - -> PropertyM IO (Maybe (Seq a)) + -> PropertyM IO (Maybe [a]) history ix = do mix <- run ix case mix of diff --git a/test/Spec/VSplit.hs b/test/Spec/VSplit.hs new file mode 100644 index 0000000000..2c8d92f78f --- /dev/null +++ b/test/Spec/VSplit.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Spec.VSplit where + +import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.Maybe (catMaybes) +import Test.QuickCheck (Property) +import Test.QuickCheck.Monadic (PropertyM, monadicIO) + +import qualified Data.Vector as V +import Control.Lens.Operators + +import Index (Index, IndexView (..)) +import qualified Index as Ix +import Index.VSplit (SplitIndex (..)) +import qualified Index.VSplit as S +import Spec.Index (Conversion (..)) + +conversion + :: Show s + => Show e + => Show n + => Default s + => Conversion (PropertyM IO) s e n +conversion = Conversion + { cView = view + , cHistory = history + , cNotifications = notifications + , cMonadic = monadic + } + +view + :: (Show s, Show e, Show n, Default s) + => Index s e n + -> PropertyM IO (Maybe (IndexView s)) +view ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + v <- S.view ix' () + pure $ Just v + +notifications + :: (Show a, Show e, Show n, Default a) + => Index a e n + -> PropertyM IO [n] +notifications ix = do + -- We should never call this on invalid indexes. + Just ix' <- run ix + pure $ S.getNotifications ix' + +history + :: (Show s, Show e, Show n, Default s) + => Index s e n + -> PropertyM IO (Maybe [s]) +history ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + h <- S.getHistory ix' () + pure $ Just h + +monadic + :: PropertyM IO Property + -> Property +monadic = monadicIO + +{- | TODO: Make the case why this interpretation tests something useful. +-} +run + :: forall s e n. (Show s, Show e, Show n, Default s) + => Index s e n + -> PropertyM IO (Maybe (SplitIndex IO (MVar s) V.Vector e n () s)) +run (Ix.New f depth store) = do + let k' = depth - 1 + liftIO $ do + mstore <- newMVar store + S.newBoxed fquery fstore foninsert k' ((k' + 1) * 2) mstore + where + fquery :: SplitIndex IO (MVar s) V.Vector e n () s -> () -> [e] -> IO s + fquery ix () es = do + oldState <- readMVar $ ix ^. S.handle + bufferedEvents <- S.getBuffer $ ix ^. S.storage + pure . fst $ foldr convertIxF (oldState, []) (es ++ bufferedEvents) + fstore :: SplitIndex IO (MVar s) V.Vector e n () s -> IO () + fstore ix = do + newState <- fquery ix () [] + _ <- swapMVar (ix ^. S.handle) newState + pure () + foninsert :: SplitIndex IO (MVar s) V.Vector e n () s -> e -> IO [n] + foninsert ix e = do + es <- S.getEvents $ ix ^. S.storage + oldState <- fquery ix () es + pure $ catMaybes [snd $ f oldState e] + convertIxF :: e -> (s, [n]) -> (s, [n]) + convertIxF e (a', ns) = + let (a'', mn) = f a' e + in (a'', catMaybes [mn] ++ ns) +run (Ix.Insert e ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + nix <- S.insert e ix' + pure $ Just nix +run (Ix.Rewind n ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO . pure $ S.rewind n ix' + From e30c0f8e6e86e6f57249aa4437ac8cadc0d49420 Mon Sep 17 00:00:00 2001 From: Radu Ometita Date: Thu, 19 May 2022 00:56:54 +0700 Subject: [PATCH 60/62] Added sqlite vector indexes. --- hysterical-screams.cabal | 2 + src/Index/VSplit.hs | 22 ++++---- src/Index/VSqlite.hs | 74 ++++++++++++++++++++++++ test/Spec.hs | 32 ++++++++--- test/Spec/VSplit.hs | 6 +- test/Spec/VSqlite.hs | 119 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 234 insertions(+), 21 deletions(-) create mode 100644 src/Index/VSqlite.hs create mode 100644 test/Spec/VSqlite.hs diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 67af551ea8..ebcdd4efb9 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -32,6 +32,7 @@ library Index.Split Index.Sqlite Index.VSplit + Index.VSqlite other-modules: Paths_hysterical_screams hs-source-dirs: @@ -69,6 +70,7 @@ test-suite hysterical-screams-test Spec.Split Spec.Sqlite Spec.VSplit + Spec.VSqlite Paths_hysterical_screams hs-source-dirs: test diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index be45c5066d..95fdd67b43 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} module Index.VSplit ( SplitIndex(..) @@ -18,7 +18,7 @@ module Index.VSplit , query , onInsert -- * Storage - , Storage + , Storage(..) , getBuffer , getEvents -- * Observations @@ -27,17 +27,17 @@ module Index.VSplit , view ) where -import Control.Lens.Operators -import qualified Control.Lens.TH as Lens -import Control.Monad.Primitive (PrimState, PrimMonad) -import Data.Foldable (foldlM) -import Data.List (tails) -import qualified Data.Vector.Generic as VG +import Control.Lens.Operators +import qualified Control.Lens.TH as Lens +import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Foldable (foldlM) +import Data.List (tails) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as VGM -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed as VU -import Index (IndexView(..)) +import Index (IndexView (..)) data Storage v m e = Storage { _events :: (VG.Mutable v) (PrimState m) e diff --git a/src/Index/VSqlite.hs b/src/Index/VSqlite.hs new file mode 100644 index 0000000000..6d2db2dfe2 --- /dev/null +++ b/src/Index/VSqlite.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Index.VSqlite + ( -- * API + SqliteIndex + , new + , newBoxed + , S.insert + , S.insertL + , S.size + , S.rewind + , S.getEvents + , S.getBuffer + , S.handle + , S.storage + -- * Observations + , S.view + , S.getHistory + , S.getNotifications + ) where + +import Control.Monad.Primitive (PrimState) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import Database.SQLite.Simple (Connection, open) + +import Index.VSplit (SplitIndex (..), Storage (..)) +import qualified Index.VSplit as S + +type SqliteIndex e n q r = SplitIndex IO Connection V.Vector e n q r + +new + :: (SqliteIndex e n q r -> q -> [e] -> IO r) + -> (SqliteIndex e n q r -> IO ()) + -> (SqliteIndex e n q r -> e -> IO [n]) + -> Int + -> FilePath + -> (VG.Mutable V.Vector) (PrimState IO) e + -> IO (Maybe (SqliteIndex e n q r)) +new fquery fstore foninsert k' db vector + | k' < 0 = pure Nothing + | otherwise = do + connection <- open db + pure . Just $ SplitIndex + { _handle = connection + , _storage = Storage { _events = vector + , _cursor = 0 + , _eSize = 0 + , _bSize = 0 + , _k = k' + } + , _notifications = [] + , _store = fstore + , _query = fquery + , _onInsert = foninsert + } + +type BoxedIndex e n q r = SqliteIndex e n q r + +newBoxed + :: (BoxedIndex e n q r -> q -> [e] -> IO r) + -> (BoxedIndex e n q r -> IO ()) + -> (BoxedIndex e n q r -> e -> IO [n]) + -> Int + -> Int + -> FilePath + -> IO (Maybe (BoxedIndex e n q r)) +newBoxed query' store' onInsert' k' size' dbPath + | k' < 0 || size' <= 0 = pure Nothing + | otherwise = do + v <- VGM.new (k' + size') + new query' store' onInsert' k' dbPath v + diff --git a/test/Spec.hs b/test/Spec.hs index 7c90111c4a..7fab905d79 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,9 +5,10 @@ import qualified Spec.Index as Ix import qualified Spec.Split as S import qualified Spec.Sqlite as Sqlite import qualified Spec.VSplit as V +import qualified Spec.VSqlite as VS tests :: TestTree -tests = testGroup "Index" [ixProperties, siProperties, sqProperties, viProperties] +tests = testGroup "Index" [ixProperties, siProperties, sqProperties, viProperties, vsProperties] ixProperties :: TestTree ixProperties = testGroup "Basic model" @@ -67,20 +68,37 @@ viProperties :: TestTree viProperties = testGroup "Vector index" [ testProperty "New: Positive or non-positive depth" $ withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int V.conversion - , testProperty "History length is always smaller than the max depth" $ + , testProperty "History length is always smaller than the max depth" $ withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int V.conversion - , testProperty "Rewind: Connection with `ixDepth`" $ + , testProperty "Rewind: Connection with `ixDepth`" $ withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int V.conversion - , testProperty "Relationship between Insert/Rewind" $ + , testProperty "Relationship between Insert/Rewind" $ withMaxSuccess 1000 $ Ix.prop_insertRewindInverse @Int @Int @Int V.conversion - , testProperty "Insert is folding the structure" $ + , testProperty "Insert is folding the structure" $ withMaxSuccess 1000 $ Ix.prop_observeInsert @Int @Int @Int V.conversion - , testProperty "Notifications are accumulated as the fold runs" $ + , testProperty "Notifications are accumulated as the fold runs" $ withMaxSuccess 1000 $ Ix.prop_observeNotifications @Int @Int @Int V.conversion - , testProperty "Notifications are not affected by rewind" $ + , testProperty "Notifications are not affected by rewind" $ withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int V.conversion ] +vsProperties :: TestTree +vsProperties = testGroup "SQLite vector index" + [ testProperty "New: Positive or non-positive depth" $ + withMaxSuccess 10000 $ Ix.prop_observeNew @Int @Int @Int VS.conversion + , testProperty "History length is always smaller than the max depth" $ + withMaxSuccess 10000 $ Ix.prop_sizeLEDepth @Int @Int @Int VS.conversion + , testProperty "Rewind: Connection with `ixDepth`" $ + withMaxSuccess 10000 $ Ix.prop_rewindDepth @Int @Int @Int VS.conversion + , testProperty "Relationship between Insert/Rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindInverse @Int @Int @Int VS.conversion + , testProperty "Insert is folding the structure" $ + withMaxSuccess 1000 $ Ix.prop_observeInsert @Int @Int @Int VS.conversion + , testProperty "Notifications are accumulated as the fold runs" $ + withMaxSuccess 1000 $ Ix.prop_observeNotifications @Int @Int @Int VS.conversion + , testProperty "Notifications are not affected by rewind" $ + withMaxSuccess 1000 $ Ix.prop_insertRewindNotifications @Int @Int @Int VS.conversion + ] main :: IO () main = do -- quickSpec ixSignature diff --git a/test/Spec/VSplit.hs b/test/Spec/VSplit.hs index 2c8d92f78f..adbbb13af7 100644 --- a/test/Spec/VSplit.hs +++ b/test/Spec/VSplit.hs @@ -9,8 +9,8 @@ import Data.Maybe (catMaybes) import Test.QuickCheck (Property) import Test.QuickCheck.Monadic (PropertyM, monadicIO) -import qualified Data.Vector as V -import Control.Lens.Operators +import Control.Lens.Operators +import qualified Data.Vector as V import Index (Index, IndexView (..)) import qualified Index as Ix @@ -18,7 +18,7 @@ import Index.VSplit (SplitIndex (..)) import qualified Index.VSplit as S import Spec.Index (Conversion (..)) -conversion +conversion :: Show s => Show e => Show n diff --git a/test/Spec/VSqlite.hs b/test/Spec/VSqlite.hs new file mode 100644 index 0000000000..2f7d300f29 --- /dev/null +++ b/test/Spec/VSqlite.hs @@ -0,0 +1,119 @@ +module Spec.VSqlite where + +import Control.Lens.Operators +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.Maybe (catMaybes) +import Database.SQLite.Simple (Only (..), execute, execute_, + query) +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField +import Test.QuickCheck (Property) +import qualified Test.QuickCheck.Monadic as M +import Test.QuickCheck.Monadic (PropertyM, monadicIO) + +import Index (Index, IndexView (..)) +import qualified Index as Ix +import Index.VSqlite (SqliteIndex) +import qualified Index.VSqlite as S +import Spec.Index (Conversion (..)) + +conversion + :: (Show e, Show n, Show a, Default a, ToField a, FromField a) + => Conversion (PropertyM IO) a e n +conversion = Conversion + { cView = view + , cHistory = history + , cNotifications = notifications + , cMonadic = monadic + } + +stateId :: Int +stateId = 1 + +view + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe (IndexView a)) +view ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> do + v <- M.run $ S.view ix' stateId + pure $ Just v + +notifications + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO [n] +notifications ix = do + -- We should never call this on invalid indexes. + Just ix' <- run ix + pure $ S.getNotifications ix' + +history + :: (Show a, Default a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe [a]) +history ix = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + h <- S.getHistory ix' stateId + pure $ Just h + +monadic + :: PropertyM IO Property + -> Property +monadic = monadicIO + +run + :: forall a e n. (Show a, Default a, ToField a, FromField a, Show e, Show n) + => Index a e n + -> PropertyM IO (Maybe (SqliteIndex e n Int a)) +run (Ix.New f depth acc) = do + let k' = depth - 1 + sqliteIndex <- liftIO $ S.newBoxed fquery fstore foninsert k' ((k' + 1) * 2) ":memory:" + case sqliteIndex of + Nothing -> pure Nothing + Just ix -> do + let c = ix ^. S.handle + -- Initialise database + liftIO $ do + execute_ c "DROP TABLE IF EXISTS index_property_tests" + execute_ c "CREATE TABLE index_property_tests (id INTEGER PRIMARY KEY, accumulator INT)" + execute c "INSERT INTO index_property_tests (id, accumulator) VALUES (?, ?)" (stateId, acc) + pure . Just $ ix + where + fstore :: SqliteIndex e n Int a -> IO () + fstore ix = do + currentStore <- fquery ix stateId [] + execute (ix ^. S.handle) "UPDATE index_property_tests SET accumulator = ? WHERE id = ?" (currentStore, stateId) + fquery :: SqliteIndex e n Int a -> Int -> [e] -> IO a + fquery ix stateId' es = do + [[storedState]] <- query (ix ^. S.handle) "SELECT (accumulator) FROM index_property_tests WHERE id = ?" (Only stateId') + bufferedEvents <- S.getBuffer (ix ^. S.storage) + pure . fst $ foldr convertIxF (storedState, []) (es ++ bufferedEvents) + foninsert :: SqliteIndex e n Int a -> e -> IO [n] + foninsert ix e = do + events <- S.getEvents (ix ^. S.storage) + currentState <- fquery ix stateId events + pure $ catMaybes [snd $ f currentState e] + convertIxF :: e -> (a, [n]) -> (a, [n]) + convertIxF e (a, ns) = + let (a', mn) = f a e + in (a', catMaybes [mn] ++ ns) +run (Ix.Insert e ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO $ do + nix <- S.insert e ix' + pure $ Just nix +run (Ix.Rewind n ix) = do + mix <- run ix + case mix of + Nothing -> pure Nothing + Just ix' -> liftIO . pure $ S.rewind n ix' From f3bbd38a19f99de5c8ddc650c94330b2d09a865b Mon Sep 17 00:00:00 2001 From: Ometita Radu Adrian Date: Sat, 28 May 2022 20:17:30 +0300 Subject: [PATCH 61/62] Added Strict flag to the build --- hysterical-screams.cabal | 4 +++- package.yaml | 1 + src/Index/Sqlite.hs | 2 ++ src/Index/VSplit.hs | 1 + test/Spec/VSqlite.hs | 2 ++ 5 files changed, 9 insertions(+), 1 deletion(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index ebcdd4efb9..59eab02a7c 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -49,6 +49,7 @@ library FlexibleInstances OverloadedStrings GADTs + Strict ghc-options: -Wall build-depends: QuickCheck @@ -86,6 +87,7 @@ test-suite hysterical-screams-test FlexibleInstances OverloadedStrings GADTs + Strict ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck diff --git a/package.yaml b/package.yaml index 8c4a5be234..406774165b 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ default-extensions: - FlexibleInstances - OverloadedStrings - GADTs + - Strict dependencies: - base >= 4.7 && < 5 diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index 831da2cb81..0fb3723692 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Strict #-} + module Index.Sqlite ( -- * API SqliteIndex diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index 95fdd67b43..b13953b8a9 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Strict #-} module Index.VSplit ( SplitIndex(..) diff --git a/test/Spec/VSqlite.hs b/test/Spec/VSqlite.hs index 2f7d300f29..664fd0ae66 100644 --- a/test/Spec/VSqlite.hs +++ b/test/Spec/VSqlite.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Strict #-} + module Spec.VSqlite where import Control.Lens.Operators From 4c523469e9efd3f0d10d17da3304923b7b0e0674 Mon Sep 17 00:00:00 2001 From: Ometita Radu Adrian Date: Tue, 31 May 2022 17:35:33 +0300 Subject: [PATCH 62/62] remove quickspec and some cleanups --- hysterical-screams.cabal | 5 +++- package.yaml | 3 +- src/Index.hs | 63 ++++++++++++++++++++-------------------- src/Index/Split.hs | 2 -- src/Index/Sqlite.hs | 2 -- src/Index/VSplit.hs | 4 --- src/Index/VSqlite.hs | 2 -- test/Spec/Index.hs | 1 - test/Spec/VSplit.hs | 2 -- 9 files changed, 38 insertions(+), 46 deletions(-) diff --git a/hysterical-screams.cabal b/hysterical-screams.cabal index 59eab02a7c..97998ec07f 100644 --- a/hysterical-screams.cabal +++ b/hysterical-screams.cabal @@ -47,9 +47,11 @@ library NamedFieldPuns MultiParamTypeClasses FlexibleInstances + FlexibleContexts OverloadedStrings GADTs Strict + TemplateHaskell ghc-options: -Wall build-depends: QuickCheck @@ -58,7 +60,6 @@ library , data-default , lens , primitive - , quickspec , sqlite-simple , vector default-language: Haskell2010 @@ -85,9 +86,11 @@ test-suite hysterical-screams-test NamedFieldPuns MultiParamTypeClasses FlexibleInstances + FlexibleContexts OverloadedStrings GADTs Strict + TemplateHaskell ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck diff --git a/package.yaml b/package.yaml index 406774165b..666d9cf5b4 100644 --- a/package.yaml +++ b/package.yaml @@ -31,14 +31,15 @@ default-extensions: - NamedFieldPuns - MultiParamTypeClasses - FlexibleInstances + - FlexibleContexts - OverloadedStrings - GADTs - Strict + - TemplateHaskell dependencies: - base >= 4.7 && < 5 - QuickCheck -- quickspec - sqlite-simple - data-default - containers diff --git a/src/Index.hs b/src/Index.hs index 2132620a02..a21cd699b3 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -15,14 +15,15 @@ module Index -- * Testing , ObservedBuilder (..) , GrammarBuilder (..) - , ixSignature + -- , ixSignature ) where import Control.Monad (replicateM) import Data.Foldable (foldl') import Data.Maybe (fromJust, maybeToList) +import Data.Typeable (Typeable) import GHC.Generics -import QuickSpec +-- import QuickSpec import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Gen, arbitrarySizedIntegral, chooseInt, frequency, listOf, shrinkNothing, sized) @@ -226,32 +227,32 @@ instance Arbitrary a => Arbitrary (IndexView a) where -- | QuickSpec -newtype IxEvents e = IxEvents [e] - deriving (Eq, Ord, Typeable) - -instance Arbitrary e => Arbitrary (IxEvents e) where - arbitrary = IxEvents <$> listOf arbitrary - -instance ( Ord a - , Arbitrary a - , Arbitrary e - , CoArbitrary a - , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e n) where - observe (IxEvents es) ix = fromJust $ view $ insertL es ix - -ixSignature :: [Sig] -ixSignature = - [ monoObserve @(Index Int String String) - , monoObserve @(Index Int Int String) - , monoObserve @(Index Int [Int] String) - , monoObserve @(Maybe (Index Int String String)) - , monoObserve @(Maybe (Index Int Int String)) - , monoObserve @(Maybe (Index Int [Int] String)) - , mono @(IndexView Int) - , con "new" (new :: (Int -> String -> (Int, Maybe String)) -> Int -> Int -> Index Int String String) - , con "insert" (insert :: String -> Index Int String String -> Index Int String String) - , con "view" (view :: Index Int String String -> Maybe (IndexView Int)) - , con "rewind" (rewind :: Int -> Index Int String String -> Index Int String String) - , con "getHistory" (getHistory :: Index Int String String -> Maybe [Int]) - , withMaxTermSize 6 - ] +-- newtype IxEvents e = IxEvents [e] +-- deriving (Eq, Ord, Typeable) + +-- instance Arbitrary e => Arbitrary (IxEvents e) where +-- arbitrary = IxEvents <$> listOf arbitrary + +-- instance ( Ord a +-- , Arbitrary a +-- , Arbitrary e +-- , CoArbitrary a +-- , CoArbitrary e) => Observe (IxEvents e) (IndexView a) (Index a e n) where +-- observe (IxEvents es) ix = fromJust $ view $ insertL es ix + +-- ixSignature :: [Sig] +-- ixSignature = +-- [ monoObserve @(Index Int String String) +-- , monoObserve @(Index Int Int String) +-- , monoObserve @(Index Int [Int] String) +-- , monoObserve @(Maybe (Index Int String String)) +-- , monoObserve @(Maybe (Index Int Int String)) +-- , monoObserve @(Maybe (Index Int [Int] String)) +-- , mono @(IndexView Int) +-- , con "new" (new :: (Int -> String -> (Int, Maybe String)) -> Int -> Int -> Index Int String String) +-- , con "insert" (insert :: String -> Index Int String String -> Index Int String String) +-- , con "view" (view :: Index Int String String -> Maybe (IndexView Int)) +-- , con "rewind" (rewind :: Int -> Index Int String String -> Index Int String String) +-- , con "getHistory" (getHistory :: Index Int String String -> Maybe [Int]) +-- , withMaxTermSize 6 +-- ] diff --git a/src/Index/Split.hs b/src/Index/Split.hs index cf7ed8e0bc..198fc20f19 100644 --- a/src/Index/Split.hs +++ b/src/Index/Split.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - module Index.Split ( -- * API SplitIndex(..) diff --git a/src/Index/Sqlite.hs b/src/Index/Sqlite.hs index 0fb3723692..831da2cb81 100644 --- a/src/Index/Sqlite.hs +++ b/src/Index/Sqlite.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE Strict #-} - module Index.Sqlite ( -- * API SqliteIndex diff --git a/src/Index/VSplit.hs b/src/Index/VSplit.hs index b13953b8a9..3620527cd0 100644 --- a/src/Index/VSplit.hs +++ b/src/Index/VSplit.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE Strict #-} - module Index.VSplit ( SplitIndex(..) , new diff --git a/src/Index/VSqlite.hs b/src/Index/VSqlite.hs index 6d2db2dfe2..5f646a83bf 100644 --- a/src/Index/VSqlite.hs +++ b/src/Index/VSqlite.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module Index.VSqlite ( -- * API SqliteIndex diff --git a/test/Spec/Index.hs b/test/Spec/Index.hs index f6338542e2..4828bfc8f4 100644 --- a/test/Spec/Index.hs +++ b/test/Spec/Index.hs @@ -3,7 +3,6 @@ module Spec.Index where import Data.Functor.Identity (Identity, runIdentity) import Data.List (foldl', isPrefixOf, scanl') import Data.Maybe (fromJust, isJust, isNothing, mapMaybe) -import QuickSpec import Test.QuickCheck.Monadic import Test.Tasty.QuickCheck diff --git a/test/Spec/VSplit.hs b/test/Spec/VSplit.hs index adbbb13af7..d44df87229 100644 --- a/test/Spec/VSplit.hs +++ b/test/Spec/VSplit.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module Spec.VSplit where import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar)