Test + fix for broken D Semigroup instance

IntersectMBO · May 14, 2021 · 17a6e47 · 17a6e47
1 parent 0cb89df
commit 17a6e47
Show file tree

Hide file tree

Showing 7 changed files with 41 additions and 6 deletions.
diff --git a/ledger-ondisk/ledger-ondisk.cabal b/ledger-ondisk/ledger-ondisk.cabal
@@ -21,6 +21,7 @@ library
   -- other-modules:
   -- other-extensions:
   exposed-modules:     LedgerOnDisk
+                       LedgerOnDisk.Suite
                        LedgerOnDisk.Class
                        LedgerOnDisk.ClassWithExceptions
                        LedgerOnDisk.Simple
@@ -49,7 +50,9 @@ library
                        async,
                        stm,
                        fingertree,
-                       time
+                       time,
+                       quickcheck-classes,
+                       tasty-quickcheck-laws
 
   hs-source-dirs:      src
   default-language:    Haskell2010

diff --git a/ledger-ondisk/src/LedgerOnDisk/Class.hs b/ledger-ondisk/src/LedgerOnDisk/Class.hs
@@ -27,7 +27,6 @@ import Control.Monad
 import Test.QuickCheck
 import Data.TreeDiff.Class
 import Test.QuickCheck.Instances.UnorderedContainers ()
-import qualified Data.Semigroup as Semi
 import Data.Monoid
 -- import Data.Proxy
 
@@ -46,7 +45,10 @@ data D v where
   -- instance (though I think this could be surmounted with a CoYoneda trick)
   -- DIMappend :: Monoid v => v -> D v
   deriving stock (Show, Eq)
-  deriving Semigroup via (Semi.Last (D v))
+
+instance Semigroup (D v) where
+  x <> DNoChange = x
+  _ <> y = y
 
 instance Monoid (D v) where
   mempty = DNoChange

diff --git a/ledger-ondisk/src/LedgerOnDisk/QSM/Model.hs b/ledger-ondisk/src/LedgerOnDisk/QSM/Model.hs
@@ -28,7 +28,10 @@
 {-# LANGUAGE ConstraintKinds #-}
 
 {-# OPTIONS -fno-warn-unused-imports #-}
+
+-- from quickcheck-state-machine, see very bottom of file
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 module LedgerOnDisk.QSM.Model where
 
 import Data.Coerce

diff --git a/ledger-ondisk/src/LedgerOnDisk/QSM/Suite.hs b/ledger-ondisk/src/LedgerOnDisk/QSM/Suite.hs
@@ -187,5 +187,4 @@ tests = testGroup "quickcheck state machine"
     ]
   , testQSM "SimpleT" simpleStateMachineTest
   , testQSM "WWBT" wwbStateMachineTest
-  -- , testLabelStateMachine "KVModel" $
   ]
diff --git a/ledger-ondisk/src/LedgerOnDisk/Simple.hs b/ledger-ondisk/src/LedgerOnDisk/Simple.hs
@@ -11,6 +11,8 @@
 
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+
+{-# OPTIONS -fno-warn-unused-imports #-}
 module LedgerOnDisk.Simple where
 
 import Control.Monad.Except

diff --git a/ledger-ondisk/src/LedgerOnDisk/Suite.hs b/ledger-ondisk/src/LedgerOnDisk/Suite.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+module LedgerOnDisk.Suite where
+
+import qualified LedgerOnDisk.QSM.Suite(tests)
+import Test.Tasty
+import qualified Test.Tasty.QuickCheck.Laws as Laws
+
+import LedgerOnDisk.Class
+import Data.Proxy
+
+testManyLaws :: forall a proxy. proxy a -> TestName -> [Proxy a -> TestTree] -> TestTree
+testManyLaws _ name = testGroup name . fmap ($ Proxy @ a)
+
+testLaws :: TestTree
+testLaws = testGroup "Laws"
+    [ testManyLaws (Proxy @ (D Int)) "D"
+      [Laws.testEqLaws, Laws.testSemigroupLaws, Laws.testMonoidLaws ]
+    ]
+
+tests :: TestTree
+tests = testGroup "LedgerOnDisk"
+  [ LedgerOnDisk.QSM.Suite.tests
+  , testLaws
+  ]
diff --git a/ledger-ondisk/test/Main.hs b/ledger-ondisk/test/Main.hs
@@ -9,15 +9,15 @@ import           Test.QuickCheck.Instances.UnorderedContainers ()
 import Data.Maybe
 
 import qualified LedgerOnDisk
-import qualified LedgerOnDisk.QSM.Suite
+import qualified LedgerOnDisk.Suite
 
 main :: IO ()
 main = defaultMain tests
 
 tests :: TestTree
 tests = testGroup "ledger-ondisk"
   [ testProperty "SimpleT lookup idempotent" $ monadKVSimple prop_kv_lookup_idempotent
-  , LedgerOnDisk.QSM.Suite.tests
+  , LedgerOnDisk.Suite.tests
   ]
   -- TODO simple properties for simple implemetnation, i.e. insert, delete