Merge pull request #367 from input-output-hk/jonathanknowles/db-qsm-t…

…ag-coverage

Make DB QSM tests fail if one or more tags are not covered.

lib/core/cardano-wallet-core.cabal

@@ -118,6 +118,7 @@ test-suite unit
     , containers
     , cryptonite
     , deepseq
+    , extra >= 1.6.17
     , file-embed
     , fmt
     , foldl

lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs

@@ -53,9 +53,11 @@ import Crypto.Hash
 import Data.Bifunctor
     ( bimap, first )
 import Data.Foldable
-    ( toList )
+    ( foldl', toList )
 import Data.Functor.Classes
     ( Eq1, Show1 )
+import Data.List.Extra
+    ( enumerate )
 import Data.Map
     ( Map )
 import Data.Maybe
@@ -640,7 +642,11 @@ data Tag
       -- ^ Private key was written then read.
     | ReadTxHistoryAfterDelete
       -- ^ wallet deleted, then tx history read.
-    deriving (Show)
+    deriving (Bounded, Enum, Eq, Ord, Show)
+
+-- | The list of all possible 'Tag' values.
+allTags :: [Tag]
+allTags = enumerate
 
 tag :: [Event Symbolic] -> [Tag]
 tag = Foldl.fold $ catMaybes <$> sequenceA
@@ -854,13 +860,24 @@ repeatedly = flip . L.foldl' . flip
 
 prop_sequential :: DBLayerTest -> Property
 prop_sequential db =
+    QC.checkCoverage $
     forAllCommands (sm dbLayerUnused) Nothing $ \cmds ->
     monadicIO $ do
         liftIO $ cleanDB db
         let sm' = sm db
         (hist, _model, res) <- runCommands sm' cmds
-        prettyCommands sm' hist $ res === Ok
+        prettyCommands sm' hist
+            $ measureTagCoverage cmds
+            $ res === Ok
+  where
+    measureTagCoverage :: Commands (At Cmd) (At Resp) -> Property -> Property
+    measureTagCoverage cmds prop = foldl' measureTag prop allTags
+      where
+        measureTag :: Property -> Tag -> Property
+        measureTag p t = QC.cover 5 (t `Set.member` matchedTags) (show t) p
 
+        matchedTags :: Set Tag
+        matchedTags = Set.fromList $ tag $ execCmds cmds
 
 prop_parallel :: DBLayerTest -> Property
 prop_parallel db =

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-13.8
+resolver: lts-13.24
 packages:
 - .
 - lib/bech32