diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index 85aa088949a..f183fb92bd9 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -322,6 +322,7 @@ library Cardano.Wallet.Primitive.Types.Redeemer Cardano.Wallet.Primitive.Types.RewardAccount Cardano.Wallet.Primitive.Types.RewardAccount.Gen + Cardano.Wallet.Primitive.Types.StateDeltaSeq Cardano.Wallet.Primitive.Types.TokenBundle Cardano.Wallet.Primitive.Types.TokenBundle.Gen Cardano.Wallet.Primitive.Types.TokenMap @@ -749,6 +750,7 @@ test-suite unit Cardano.Wallet.Primitive.Types.AddressSpec Cardano.Wallet.Primitive.Types.CoinSpec Cardano.Wallet.Primitive.Types.HashSpec + Cardano.Wallet.Primitive.Types.StateDeltaSeqSpec Cardano.Wallet.Primitive.Types.TokenBundleSpec Cardano.Wallet.Primitive.Types.TokenMapSpec Cardano.Wallet.Primitive.Types.TokenMapSpec.TypeErrorSpec diff --git a/lib/wallet/src/Cardano/Wallet/Primitive/Types/StateDeltaSeq.hs b/lib/wallet/src/Cardano/Wallet/Primitive/Types/StateDeltaSeq.hs new file mode 100644 index 00000000000..f81126c182f --- /dev/null +++ b/lib/wallet/src/Cardano/Wallet/Primitive/Types/StateDeltaSeq.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © 2022 IOHK +-- License: Apache-2.0 +-- +-- This module provides the 'StateDeltaSeq' type and related functions. +-- +-- The 'StateDeltaSeq' type provides a way to model an abstract linear sequence +-- of state transitions, where each transition consists of an initial state +-- value, a delta value, and a final state value. +-- +-- Such sequences are __contiguous__, such that the final state of any given +-- transition is the initial state of the next transition in the sequence: +-- +-- @ +-- transition_0_1: state_0 -> delta_0_1 -> state_1 +-- transition_1_2: state_1 -> delta_1_2 -> state_2 +-- transition_2_3: state_2 -> delta_2_3 -> state_3 +-- ... +-- transition_p_q: state_p -> delta_p_q -> state_q +-- @ +-- +-- By itself, the 'StateDeltaSeq` type does not maintain any invariant relating +-- to the validity of individual transitions, and does not maintain any +-- knowledge of how to apply delta values to state values. +-- +-- Instead, the 'StateDeltaSeq' type only ensures that transition sequences are +-- contiguous (see above). Ensuring and preserving validity of transitions is +-- the responsibility of the consumer. +-- +-- However, when given a transition function of type 'state -> delta -> state', +-- the 'StateDeltaSeq' type does provide several functions for constructing +-- sequences that are valid, and verifying that existing sequences are valid. +-- +-- Basic usage: +-- +-- - Use 'fromStateDeltas' to construct a sequence. +-- - Use 'applyDelta' to extend a sequence. +-- - Use 'isValid' to verify a sequence. +-- - Use 'toTransitionList' to list all transitions of a sequence. +-- +module Cardano.Wallet.Primitive.Types.StateDeltaSeq + ( + -- * Types + StateDeltaSeq + + -- * Constructors + , fromState + , fromStateDeltas + , fromStateDeltasUnchecked + + -- * Indicators + , isPrefixOf + , isSuffixOf + , isValid + , isValidM + + -- * Conversions + , toDeltaList + , toStateList + , toTransitionList + + -- * Views + , headState + , lastState + + -- * Maps + , mapDeltas + , mapStates + , mapStatesDeltas + + -- * Counts + , countTransitions + , countTransitionsWhere + , countEmptyTransitions + , countEmptyTransitionsWhere + + -- * Extension + , applyDelta + , applyDeltas + , applyDeltaM + , applyDeltasM + + -- * Shrinking + , dropEmptyTransition + , dropEmptyTransitions + , dropEmptyTransitionWhere + , dropEmptyTransitionsWhere + , dropHead + , dropLast + , prefixes + , suffixes + + ) where + +import Prelude hiding + ( head, iterate, seq, tail ) + +import Control.Applicative + ( ZipList (..) ) +import Control.Monad + ( foldM ) +import Control.Monad.Extra + ( allM ) +import Control.Monad.Identity + ( Identity (..) ) +import Data.Bifoldable + ( Bifoldable (..) ) +import Data.Bifunctor + ( Bifunctor (..) ) +import Data.Coerce + ( coerce ) +import Data.Function + ( on ) +import Data.Functor + ( (<&>) ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Sequence + ( Seq ((:<|), (:|>), Empty) ) + +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Sequence as Seq + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | The 'StateDeltaSeq' type provides a way to model an abstract sequence of +-- state transitions, where each transition consists of an initial state +-- value, a delta value, and a final state value. +-- +-- Such sequences are __contiguous__, such that the final state of any given +-- transition is the initial state of the next transition in the sequence: +-- +-- @ +-- transition_0_1: state_0 -> delta_0_1 -> state_1 +-- transition_1_2: state_1 -> delta_1_2 -> state_2 +-- transition_2_3: state_2 -> delta_2_3 -> state_3 +-- ... +-- transition_p_q: state_p -> delta_p_q -> state_q +-- @ +-- +data StateDeltaSeq state delta = StateDeltaSeq + { head :: !state + , tail :: !(Seq (delta, state)) + } + deriving Eq + +-- | The type of list elements returned by 'toStateDeltaList'. +-- +data StateDeltaListItem state delta + = State !state + | Delta !delta + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +instance Bifoldable StateDeltaSeq where + bifoldMap f g s = head <> F.foldMap (uncurry (<>)) tail + where + StateDeltaSeq {head, tail} = mapStatesDeltas f g s + +instance Bifunctor StateDeltaSeq where + bimap = mapStatesDeltas + first = mapStates + second = mapDeltas + +instance Foldable (StateDeltaSeq state) where + foldMap f s = F.foldMap f (toDeltaList s) + length = countTransitions + +instance Functor (StateDeltaSeq state) where + fmap = mapDeltas + +instance (Show state, Show delta) => Show (StateDeltaSeq state delta) where + show = show . NE.toList . toStateDeltaList + +-------------------------------------------------------------------------------- +-- Constructors +-------------------------------------------------------------------------------- + +-- | Constructs a 'StateDeltaSeq' from an initial state. +-- +-- The resultant sequence will have no transitions. +-- +-- To add a transition to the sequence, use the 'applyDelta' function. +-- +fromState :: s -> StateDeltaSeq s d +fromState state = StateDeltaSeq state Seq.empty + +-- | Constructs a 'StateDeltaSeq' from an initial state and a sequence of +-- deltas, according to a given state transition function. +-- +-- To add further transitions to the sequence, use the 'applyDelta' function. +-- +fromStateDeltas :: (s -> d -> s) -> s -> [d] -> StateDeltaSeq s d +fromStateDeltas next s ds = applyDeltas next ds (fromState s) + +-- | Constructs a 'StateDeltaSeq' from an initial state and a sequence of +-- deltas, without a state transition function to ensure validity. +-- +fromStateDeltasUnchecked :: s -> [(d, s)] -> StateDeltaSeq s d +fromStateDeltasUnchecked head deltaStates = + StateDeltaSeq head (Seq.fromList deltaStates) + +-------------------------------------------------------------------------------- +-- Counts +-------------------------------------------------------------------------------- + +-- | Counts the total number of transitions in a 'StateDeltaSeq'. +-- +countTransitions :: StateDeltaSeq s d -> Int +countTransitions StateDeltaSeq {tail} = Seq.length tail + +-- | Counts the number of transitions in a 'StateDeltaSeq' for which the given +-- indicator function returns 'True'. +-- +countTransitionsWhere :: ((s, d, s) -> Bool) -> StateDeltaSeq s d -> Int +countTransitionsWhere f s = length $ findTransitionsWhere f s + +-- | Counts the number of empty transitions in a 'StateDeltaSeq'. +-- +-- A transition is empty if its initial state is equal to its final state. +-- +countEmptyTransitions :: Eq s => StateDeltaSeq s d -> Int +countEmptyTransitions = countEmptyTransitionsWhere (const True) + +-- | Counts the number of empty transitions in a 'StateDeltaSeq' for which the +-- given indicator function returns 'True'. +-- +-- A transition is empty if its initial state is equal to its final state. +-- +countEmptyTransitionsWhere :: Eq s => (d -> Bool) -> StateDeltaSeq s d -> Int +countEmptyTransitionsWhere f s = length $ emptyTransitionsWhere f s + +-------------------------------------------------------------------------------- +-- Indicators +-------------------------------------------------------------------------------- + +-- | Returns 'True' if (and only if) the first sequence is a prefix of the +-- second sequence. +-- +-- If the sequences are identical, this function returns 'True'. +-- +isPrefixOf :: (Eq s, Eq d) => StateDeltaSeq s d -> StateDeltaSeq s d -> Bool +isPrefixOf = L.isPrefixOf `on` toTransitionList + +-- | Returns 'True' if (and only if) the first sequence is a suffix of the +-- second sequence. +-- +-- If the sequences are identical, this function returns 'True'. +-- +isSuffixOf :: (Eq s, Eq d) => StateDeltaSeq s d -> StateDeltaSeq s d -> Bool +isSuffixOf = L.isSuffixOf `on` toTransitionList + +-- | Returns 'True' if (and only if) the given sequence is valid according to +-- the given state transition function. +-- +isValid :: (Eq s) => (s -> d -> s) -> StateDeltaSeq s d -> Bool +isValid next = runIdentity . isValidM (coerce next) + +-- | Returns 'True' if (and only if) the given sequence is valid according to +-- the given monadic state transition function. +-- +isValidM :: (Monad m, Eq s) => (s -> d -> m s) -> StateDeltaSeq s d -> m Bool +isValidM next = allM (\(si, d, sj) -> (==) sj <$> next si d) . toTransitionList + +-------------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------------- + +-- | Generates the complete list of deltas for a given 'StateDeltaSeq'. +-- +toDeltaList :: StateDeltaSeq s d -> [d] +toDeltaList = fmap fst . F.toList . tail + +-- | Generates the complete list of states for a given 'StateDeltaSeq'. +-- +toStateList :: StateDeltaSeq s d -> NonEmpty s +toStateList StateDeltaSeq {head, tail} = head :| (snd <$> F.toList tail) + +-- | Converts the given 'StateDeltaSeq' to an alternating list of states and +-- deltas. +-- +toStateDeltaList :: StateDeltaSeq s d -> NonEmpty (StateDeltaListItem s d) +toStateDeltaList s = NE.fromList $ interleave + (State <$> F.toList (toStateList s)) + (Delta <$> F.toList (toDeltaList s)) + +-- | Converts the given 'StateDeltaSeq' to a list of transitions. +-- +-- For any consecutive pair of transitions in the resultant list, the final +-- state of the first transition is guaranteed to be identical to the initial +-- state of the second transition. +-- +toTransitionList :: StateDeltaSeq s d -> [(s, d, s)] +toTransitionList s = getZipList $ (,,) + <$> ZipList states + <*> ZipList deltas + <*> ZipList (drop 1 states) + where + deltas = F.toList $ toDeltaList s + states = F.toList $ toStateList s + +-------------------------------------------------------------------------------- +-- Views +-------------------------------------------------------------------------------- + +-- | Views the head (initial) state of a 'StateDeltaSeq'. +-- +headState :: StateDeltaSeq s d -> s +headState StateDeltaSeq {head} = head + +-- | Views the last (final) state of a 'StateDeltaSeq'. +-- +lastState :: StateDeltaSeq s d -> s +lastState StateDeltaSeq {head, tail} = case tail of + Empty -> head + _ :|> (_, s) -> s + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + +-- | Applies the given function to all delta values of a 'StateDeltaSeq'. +-- +-- To verify whether the resulting sequence is valid, use 'isValid'. +-- +mapDeltas :: (d1 -> d2) -> StateDeltaSeq s d1 -> StateDeltaSeq s d2 +mapDeltas f StateDeltaSeq {head, tail} = StateDeltaSeq + {head, tail = first f <$> tail} + +-- | Applies the given function to all state values of a 'StateDeltaSeq'. +-- +-- To verify whether the resulting sequence is valid, use 'isValid'. +-- +mapStates :: (s1 -> s2) -> StateDeltaSeq s1 d -> StateDeltaSeq s2 d +mapStates f StateDeltaSeq {head, tail} = StateDeltaSeq + {head = f head, tail = second f <$> tail} + +-- | Transforms both the state and delta values of a 'StateDeltaSeq'. +-- +-- To verify whether the resulting sequence is valid, use 'isValid'. +-- +mapStatesDeltas + :: (s1 -> s2) -> (d1 -> d2) -> StateDeltaSeq s1 d1 -> StateDeltaSeq s2 d2 +mapStatesDeltas f g StateDeltaSeq {head, tail} = StateDeltaSeq + {head = f head, tail = bimap g f <$> tail} + +-------------------------------------------------------------------------------- +-- Extension +-------------------------------------------------------------------------------- + +-- | Extends a 'StateDeltaSeq' with an additional delta, according to the given +-- state transition function. +-- +-- If the original sequence was valid according to the given state transition +-- function, then the resulting sequence will also be valid. +-- +-- To verify whether the resulting sequence is valid, use 'isValid'. +-- +applyDelta :: (s -> d -> s) -> d -> StateDeltaSeq s d -> StateDeltaSeq s d +applyDelta next delta = runIdentity . applyDeltaM (coerce next) delta + +-- | Extends a 'StateDeltaSeq' with an additional delta, according to the given +-- monadic state transition function. +-- +-- If the original sequence was valid according to the given state transition +-- function, then the resulting sequence will also be valid. +-- +-- To verify whether the resulting sequence is valid, use 'isValid'. +-- +applyDeltaM + :: Functor m + => (s -> d -> m s) + -> d + -> StateDeltaSeq s d + -> m (StateDeltaSeq s d) +applyDeltaM next delta seq@StateDeltaSeq {head, tail} = + next (lastState seq) delta <&> \state -> + StateDeltaSeq {head, tail = tail :|> (delta, state)} + +-- | Extends a 'StateDeltaSeq' with multiple additional deltas, according to +-- the given state transition function. +-- +-- See 'applyDelta'. +-- +applyDeltas + :: Foldable f + => (s -> d -> s) + -> f d + -> StateDeltaSeq s d + -> StateDeltaSeq s d +applyDeltas next deltas seq = F.foldl' (flip (applyDelta next)) seq deltas + +-- | Extends a 'StateDeltaSeq' with multiple additional deltas, according to +-- the given monadic state transition function. +-- +-- See 'applyDeltas'. +-- +applyDeltasM + :: (Foldable f, Monad m) + => (s -> d -> m s) + -> f d + -> StateDeltaSeq s d + -> m (StateDeltaSeq s d) +applyDeltasM next deltas seq = foldM (flip (applyDeltaM next)) seq deltas + +-------------------------------------------------------------------------------- +-- Shrinking +-------------------------------------------------------------------------------- + +-- | Removes the head (left-most) transition of a 'StateDeltaSeq'. +-- +dropHead :: StateDeltaSeq s d -> Maybe (StateDeltaSeq s d) +dropHead StateDeltaSeq {tail} = case tail of + Empty -> Nothing + (_, head) :<| xs -> Just StateDeltaSeq {head, tail = xs} + +-- | Removes the last (right-most) transition of a 'StateDeltaSeq'. +-- +dropLast :: StateDeltaSeq s d -> Maybe (StateDeltaSeq s d) +dropLast StateDeltaSeq {head, tail} = case tail of + Empty -> Nothing + xs :|> _ -> Just StateDeltaSeq {head, tail = xs} + +-- | Lists all proper prefixes of the given 'StateDeltaSeq'. +-- +-- The list is sorted into ascending order of length, such that each element is +-- a proper prefix of the subsequent element: +-- +-- @ +-- [ [] +-- , [transition_0_1] +-- , [transition_0_1, transition_1_2] +-- , [transition_0_1, transition_1_2, transition_2_3] +-- , ... +-- ] +-- @ +-- +-- The original sequence is not included in the result. +-- +prefixes :: StateDeltaSeq s d -> [StateDeltaSeq s d] +prefixes = iterateMaybe dropLast + +-- | Lists all proper suffixes of the given 'StateDeltaSeq'. +-- +-- The list is sorted into ascending order of length, such that each element is +-- a proper suffix of the subsequent element: +-- +-- @ +-- [ [] +-- , [transition_r_s] +-- , [transition_q_r, transition_r_s] +-- , [transition_p_q, transition_q_r, transition_r_s] +-- , ... +-- ] +-- @ +-- +-- The original sequence is not included in the result. +-- +suffixes :: StateDeltaSeq s d -> [StateDeltaSeq s d] +suffixes = iterateMaybe dropHead + +-- | For a given sequence 's', generates all proper subsequences of 's' where +-- exactly one empty transition has been removed. +-- +dropEmptyTransition + :: Eq s => StateDeltaSeq s d -> [StateDeltaSeq s d] +dropEmptyTransition = dropEmptyTransitionWhere (const True) + +-- | For a given sequence 's', generates all proper subsequences of 's' where +-- exactly one empty transition matching the given indicator function has +-- been removed. +-- +dropEmptyTransitionWhere + :: Eq s => (d -> Bool) -> StateDeltaSeq s d -> [StateDeltaSeq s d] +dropEmptyTransitionWhere f s@StateDeltaSeq {head, tail} = + StateDeltaSeq head . flip Seq.deleteAt tail <$> emptyTransitionsWhere f s + +-- | Removes all empty transitions from a 'StateDeltaSeq'. +-- +dropEmptyTransitions + :: Eq s => StateDeltaSeq s d -> StateDeltaSeq s d +dropEmptyTransitions = dropEmptyTransitionsWhere (const True) + +-- | Removes all empty transitions that match the given indicator function +-- from a 'StateDeltaSeq'. +-- +dropEmptyTransitionsWhere + :: Eq s => (d -> Bool) -> StateDeltaSeq s d -> StateDeltaSeq s d +dropEmptyTransitionsWhere f s@StateDeltaSeq {head, tail} = StateDeltaSeq head $ + F.foldl' (flip Seq.deleteAt) tail (reverse $ emptyTransitionsWhere f s) + +-------------------------------------------------------------------------------- +-- Internal functions +-------------------------------------------------------------------------------- + +-- | Finds the indices of empty transitions that match the given indicator +-- function. +-- +emptyTransitionsWhere :: Eq s => (d -> Bool) -> StateDeltaSeq s d -> [Int] +emptyTransitionsWhere f = + findTransitionsWhere $ \(si, d, sj) -> si == sj && f d + +-- | Finds the indices of all transitions that match the given indicator +-- function. +-- +findTransitionsWhere :: ((s, d, s) -> Bool) -> StateDeltaSeq s d -> [Int] +findTransitionsWhere f s = fst <$> + filter + (f . snd) + (zip [0 ..] (toTransitionList s)) + +-- | Interleaves two lists together in an alternating fashion. +-- +-- The head of the first list appears first in the resulting list. +-- +-- All items are preserved. +-- +interleave :: [a] -> [a] -> [a] +interleave (a1 : a1s) (a2 : a2s) = a1 : a2 : interleave a1s a2s +interleave ( a1s) [ ] = a1s +interleave [ ] ( a2s) = a2s + +-- | Repeatedly applies a given function to an initial value until the result +-- is 'Nothing'. +-- +iterateMaybe :: (a -> Maybe a) -> a -> [a] +iterateMaybe f = + loop [] + where + loop !as !a = maybe as (\p -> loop (p : as) p) (f a) diff --git a/lib/wallet/test/unit/Cardano/Wallet/Primitive/Types/StateDeltaSeqSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Primitive/Types/StateDeltaSeqSpec.hs new file mode 100644 index 00000000000..c7f4ba0f23c --- /dev/null +++ b/lib/wallet/test/unit/Cardano/Wallet/Primitive/Types/StateDeltaSeqSpec.hs @@ -0,0 +1,654 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Wallet.Primitive.Types.StateDeltaSeqSpec + ( spec + ) where + +import Prelude hiding + ( seq ) + +import Cardano.Wallet.Primitive.Types.StateDeltaSeq + ( StateDeltaSeq ) +import Data.Function + ( (&) ) +import GHC.Generics + ( Generic ) +import Safe + ( tailMay ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..) + , CoArbitrary + , Fun + , Function + , Gen + , Property + , applyFun + , arbitraryBoundedEnum + , checkCoverage + , choose + , cover + , genericShrink + , listOf + , property + , shrinkMapBy + , (===) + ) +import Test.QuickCheck.Classes + ( bifoldableLaws + , bifunctorLaws + , eqLaws + , foldableLaws + , functorLaws + , showLaws + ) +import Test.Utils.Laws + ( testLawsMany ) + +import qualified Cardano.Wallet.Primitive.Types.StateDeltaSeq as Seq +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE + +spec :: Spec +spec = do + + describe "Instances" $ do + + testLawsMany @(StateDeltaSeq TestState TestDelta) + [ eqLaws + , showLaws + ] + testLawsMany @(StateDeltaSeq TestState) + [ foldableLaws + , functorLaws + ] + testLawsMany @StateDeltaSeq + [ bifoldableLaws + , bifunctorLaws + ] + + describe "Constructors" $ do + + describe "fromState" $ do + it "prop_fromState_isValid" $ + prop_fromState_isValid + & property + it "prop_fromState_headState" $ + prop_fromState_headState + & property + it "prop_fromState_lastState" $ + prop_fromState_lastState + & property + it "prop_fromState_length" $ + prop_fromState_length + & property + + describe "fromStateDeltas" $ do + it "prop_fromStateDeltas_isValid" $ + prop_fromStateDeltas_isValid + & property + it "prop_fromStateDeltas_headState" $ + prop_fromStateDeltas_headState + & property + it "prop_fromStateDeltas_lastState" $ + prop_fromStateDeltas_lastState + & property + it "prop_fromStateDeltas_length" $ + prop_fromStateDeltas_length + & property + + describe "Conversions" $ do + + describe "toTransitionList" $ do + it "prop_toTransitionList_consecutivePairs" $ + prop_toTransitionList_consecutivePairs + & property + it "prop_toTransitionList_countTransitions" $ + prop_toTransitionList_countTransitions + & property + it "prop_toTransitionList_length" $ + prop_toTransitionList_length + & property + it "prop_toTransitionList_nextState" $ + prop_toTransitionList_nextState + & property + it "prop_toTransitionList_toDeltaList" $ + prop_toTransitionList_toDeltaList + & property + it "prop_toTransitionList_toStateList_initials" $ + prop_toTransitionList_toStateList_initials + & property + it "prop_toTransitionList_toStateList_finals" $ + prop_toTransitionList_toStateList_finals + & property + + describe "Counts" $ do + + describe "countEmptyTransitionsWhere" $ do + it "prop_countEmptyTransitionsWhere_coverage" $ + prop_countEmptyTransitionsWhere_coverage + & property + + describe "Extension" $ do + + describe "applyDeltas" $ do + it "prop_applyDeltas_headState" $ + prop_applyDeltas_headState + & property + it "prop_applyDeltas_length" $ + prop_applyDeltas_length + & property + + describe "Shrinking" $ do + + describe "dropEmptyTransitions" $ do + it "prop_dropEmptyTransitions_toStateList" $ + prop_dropEmptyTransitions_toStateList + & property + + describe "dropEmptyTransitionWhere" $ do + it "prop_dropEmptyTransitionWhere_countEmptyTransitionsWhere" $ + prop_dropEmptyTransitionWhere_countEmptyTransitionsWhere + & property + it "prop_dropEmptyTransitionWhere_isValid" $ + prop_dropEmptyTransitionWhere_isValid + & property + it "prop_dropEmptyTransitionWhere_headState" $ + prop_dropEmptyTransitionWhere_headState + & property + it "prop_dropEmptyTransitionWhere_lastState" $ + prop_dropEmptyTransitionWhere_lastState + & property + it "prop_dropEmptyTransitionWhere_length" $ + prop_dropEmptyTransitionWhere_length + & property + + describe "dropEmptyTransitionsWhere" $ do + it "prop_dropEmptyTransitionsWhere_countEmptyTransitionsWhere" $ + prop_dropEmptyTransitionsWhere_countEmptyTransitionsWhere + & property + it "prop_dropEmptyTransitionsWhere_isValid" $ + prop_dropEmptyTransitionsWhere_isValid + & property + it "prop_dropEmptyTransitionsWhere_headState" $ + prop_dropEmptyTransitionsWhere_headState + & property + it "prop_dropEmptyTransitionsWhere_lastState" $ + prop_dropEmptyTransitionsWhere_lastState + & property + it "prop_dropEmptyTransitionsWhere_length" $ + prop_dropEmptyTransitionsWhere_length + & property + + describe "prefixes" $ do + it "prop_prefixes_head" $ + prop_prefixes_head + & property + it "prop_prefixes_last" $ + prop_prefixes_last + & property + it "prop_prefixes_length" $ + prop_prefixes_length + & property + it "prop_prefixes_isPrefixOf" $ + prop_prefixes_isPrefixOf + & property + it "prop_prefixes_isValid" $ + prop_prefixes_isValid + & property + + describe "suffixes" $ do + it "prop_suffixes_head" $ + prop_suffixes_head + & property + it "prop_suffixes_last" $ + prop_suffixes_last + & property + it "prop_suffixes_length" $ + prop_suffixes_length + & property + it "prop_suffixes_isSuffixOf" $ + prop_suffixes_isSuffixOf + & property + it "prop_suffixes_isValid" $ + prop_suffixes_isValid + & property + +-------------------------------------------------------------------------------- +-- fromState +-------------------------------------------------------------------------------- + +prop_fromState_isValid :: TestState -> Property +prop_fromState_isValid state = + Seq.isValid applyTestDelta (Seq.fromState state) + === True + +prop_fromState_headState :: TestState -> Property +prop_fromState_headState state = + Seq.headState (Seq.fromState state) + === state + +prop_fromState_lastState :: TestState -> Property +prop_fromState_lastState state = + Seq.lastState (Seq.fromState state) + === state + +prop_fromState_length :: TestState -> Property +prop_fromState_length state = + length (Seq.fromState state) + === 0 + +-------------------------------------------------------------------------------- +-- fromStateDeltas +-------------------------------------------------------------------------------- + +prop_fromStateDeltas_isValid :: TestState -> [TestDelta] -> Property +prop_fromStateDeltas_isValid state deltas = + Seq.isValid applyTestDelta (Seq.fromStateDeltas applyTestDelta state deltas) + === True + +prop_fromStateDeltas_headState :: TestState -> [TestDelta] -> Property +prop_fromStateDeltas_headState state deltas = + Seq.headState (Seq.fromStateDeltas applyTestDelta state deltas) + === state + +prop_fromStateDeltas_lastState :: TestState -> [TestDelta] -> Property +prop_fromStateDeltas_lastState state deltas = + Seq.lastState (Seq.fromStateDeltas applyTestDelta state deltas) + === F.foldl' applyTestDelta state deltas + +prop_fromStateDeltas_length :: TestState -> [TestDelta] -> Property +prop_fromStateDeltas_length state deltas = + length (Seq.fromStateDeltas applyTestDelta state deltas) + === length deltas + +-------------------------------------------------------------------------------- +-- toTransitionList +-------------------------------------------------------------------------------- + +prop_toTransitionList_consecutivePairs + :: TestStateDeltaSeq -> Property +prop_toTransitionList_consecutivePairs (TestStateDeltaSeq seq) = + all (\((_, _, sf), (si, _, _)) -> sf == si) + (consecutivePairs (Seq.toTransitionList seq)) + === True + +prop_toTransitionList_countTransitions + :: TestStateDeltaSeq -> Property +prop_toTransitionList_countTransitions (TestStateDeltaSeq seq) = + length (Seq.toTransitionList seq) + === Seq.countTransitions seq + +prop_toTransitionList_length + :: TestStateDeltaSeq -> Property +prop_toTransitionList_length (TestStateDeltaSeq seq) = + length (Seq.toTransitionList seq) + === length seq + +prop_toTransitionList_nextState + :: TestStateDeltaSeq -> Property +prop_toTransitionList_nextState (TestStateDeltaSeq seq) = + all (\(si, d, sf) -> applyTestDelta si d == sf) (Seq.toTransitionList seq) + === True + +prop_toTransitionList_toDeltaList + :: TestStateDeltaSeq -> Property +prop_toTransitionList_toDeltaList (TestStateDeltaSeq seq) = + fmap (\(_, d, _) -> d) (Seq.toTransitionList seq) + === Seq.toDeltaList seq + +prop_toTransitionList_toStateList_initials + :: TestStateDeltaSeq -> Property +prop_toTransitionList_toStateList_initials (TestStateDeltaSeq seq) = + fmap (\(si, _, _) -> si) (Seq.toTransitionList seq) + === NE.take (length seq) (Seq.toStateList seq) + +prop_toTransitionList_toStateList_finals + :: TestStateDeltaSeq -> Property +prop_toTransitionList_toStateList_finals (TestStateDeltaSeq seq) = + fmap (\(_, _, sf) -> sf) (Seq.toTransitionList seq) + === NE.drop 1 (Seq.toStateList seq) + +-------------------------------------------------------------------------------- +-- applyDeltas +-------------------------------------------------------------------------------- + +prop_applyDeltas_headState + :: TestStateDeltaSeq -> [TestDelta] -> Property +prop_applyDeltas_headState (TestStateDeltaSeq seq) deltas = + Seq.headState (Seq.applyDeltas applyTestDelta deltas seq) + === Seq.headState seq + +prop_applyDeltas_length + :: TestStateDeltaSeq -> [TestDelta] -> Property +prop_applyDeltas_length (TestStateDeltaSeq seq) deltas = + length (Seq.applyDeltas applyTestDelta deltas seq) + === length seq + length deltas + +-------------------------------------------------------------------------------- +-- countEmptyTransitionsWhere +-------------------------------------------------------------------------------- + +prop_countEmptyTransitionsWhere_coverage + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_countEmptyTransitionsWhere_coverage + (TestStateDeltaSeq seq) (applyFun -> f) = + checkCoverage $ + cover 10 + (strictlyIncreasing [0, matchCount, emptyCount, length seq]) + "strictlyIncreasing [0, matchCount, emptyCount, length seq]" $ + property True + where + emptyCount = Seq.countEmptyTransitions seq + matchCount = Seq.countEmptyTransitionsWhere f seq + +-------------------------------------------------------------------------------- +-- dropEmptyTransitions +-------------------------------------------------------------------------------- + +prop_dropEmptyTransitions_toStateList + :: TestStateDeltaSeq -> Property +prop_dropEmptyTransitions_toStateList (TestStateDeltaSeq seq) = + NE.toList (Seq.toStateList $ Seq.dropEmptyTransitions seq) + === removeConsecutiveDuplicates (NE.toList $ Seq.toStateList seq) + +-------------------------------------------------------------------------------- +-- dropEmptyTransitionWhere +-------------------------------------------------------------------------------- + +prop_dropEmptyTransitionWhere_countEmptyTransitionsWhere + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionWhere_countEmptyTransitionsWhere + (TestStateDeltaSeq seq) (applyFun -> f) = + all ((== pred emptyTransitionCount) . Seq.countEmptyTransitionsWhere f) + (Seq.dropEmptyTransitionWhere f seq) + === True + where + emptyTransitionCount = Seq.countEmptyTransitionsWhere f seq + +prop_dropEmptyTransitionWhere_isValid + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionWhere_isValid + (TestStateDeltaSeq seq) (applyFun -> f) = + all (Seq.isValid applyTestDelta) (Seq.dropEmptyTransitionWhere f seq) + === True + +prop_dropEmptyTransitionWhere_headState + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionWhere_headState + (TestStateDeltaSeq seq) (applyFun -> f) = + all ((== Seq.headState seq) . Seq.headState) + (Seq.dropEmptyTransitionWhere f seq) + === True + +prop_dropEmptyTransitionWhere_lastState + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionWhere_lastState + (TestStateDeltaSeq seq) (applyFun -> f) = + all ((== Seq.lastState seq) . Seq.lastState) + (Seq.dropEmptyTransitionWhere f seq) + === True + +prop_dropEmptyTransitionWhere_length + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionWhere_length + (TestStateDeltaSeq seq) (applyFun -> f) = + length (Seq.dropEmptyTransitionWhere f seq) + === Seq.countEmptyTransitionsWhere f seq + +-------------------------------------------------------------------------------- +-- dropEmptyTransitionsWhere +-------------------------------------------------------------------------------- + +prop_dropEmptyTransitionsWhere_countEmptyTransitionsWhere + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionsWhere_countEmptyTransitionsWhere + (TestStateDeltaSeq seq) (applyFun -> f) = + Seq.countEmptyTransitionsWhere f (Seq.dropEmptyTransitionsWhere f seq) + === 0 + +prop_dropEmptyTransitionsWhere_isValid + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionsWhere_isValid + (TestStateDeltaSeq seq) (applyFun -> f) = + Seq.isValid applyTestDelta (Seq.dropEmptyTransitionsWhere f seq) + === True + +prop_dropEmptyTransitionsWhere_headState + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionsWhere_headState + (TestStateDeltaSeq seq) (applyFun -> f) = + Seq.headState (Seq.dropEmptyTransitionsWhere f seq) + === Seq.headState seq + +prop_dropEmptyTransitionsWhere_lastState + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionsWhere_lastState + (TestStateDeltaSeq seq) (applyFun -> f) = + Seq.lastState (Seq.dropEmptyTransitionsWhere f seq) + === Seq.lastState seq + +prop_dropEmptyTransitionsWhere_length + :: TestStateDeltaSeq -> Fun TestDelta Bool -> Property +prop_dropEmptyTransitionsWhere_length + (TestStateDeltaSeq seq) (applyFun -> f) = + length (Seq.dropEmptyTransitionsWhere f seq) + + Seq.countEmptyTransitionsWhere f seq + === length seq + +-------------------------------------------------------------------------------- +-- prefixes +-------------------------------------------------------------------------------- + +prop_prefixes_head + :: TestStateDeltaSeq -> Property +prop_prefixes_head (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.prefixes seq) of + Nothing -> + length seq === 0 + Just ss -> + NE.head ss === Seq.fromState (Seq.headState seq) + +prop_prefixes_last + :: TestStateDeltaSeq -> Property +prop_prefixes_last (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.prefixes seq) of + Nothing -> + length seq === 0 + Just ss -> + Just (NE.last ss) === Seq.dropLast seq + +prop_prefixes_length + :: TestStateDeltaSeq -> Property +prop_prefixes_length (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.prefixes seq) of + Nothing -> + length seq === 0 + Just ss -> + NE.length ss === length seq + +prop_prefixes_isPrefixOf + :: TestStateDeltaSeq -> Property +prop_prefixes_isPrefixOf (TestStateDeltaSeq seq) = + all (uncurry Seq.isPrefixOf) (consecutivePairs (Seq.prefixes seq)) + === True + +prop_prefixes_isValid + :: TestStateDeltaSeq -> Property +prop_prefixes_isValid (TestStateDeltaSeq seq) = + all (Seq.isValid applyTestDelta) (Seq.prefixes seq) + === True + +-------------------------------------------------------------------------------- +-- suffixes +-------------------------------------------------------------------------------- + +prop_suffixes_head + :: TestStateDeltaSeq -> Property +prop_suffixes_head (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.suffixes seq) of + Nothing -> + length seq === 0 + Just ss -> + NE.head ss === Seq.fromState (Seq.lastState seq) + +prop_suffixes_last + :: TestStateDeltaSeq -> Property +prop_suffixes_last (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.suffixes seq) of + Nothing -> + length seq === 0 + Just ss -> + Just (NE.last ss) === Seq.dropHead seq + +prop_suffixes_length + :: TestStateDeltaSeq -> Property +prop_suffixes_length (TestStateDeltaSeq seq) = + case NE.nonEmpty (Seq.suffixes seq) of + Nothing -> + length seq === 0 + Just ss -> + NE.length ss === length seq + +prop_suffixes_isSuffixOf + :: TestStateDeltaSeq -> Property +prop_suffixes_isSuffixOf (TestStateDeltaSeq seq) = + all (uncurry Seq.isSuffixOf) (consecutivePairs (Seq.suffixes seq)) + === True + +prop_suffixes_isValid + :: TestStateDeltaSeq -> Property +prop_suffixes_isValid (TestStateDeltaSeq seq) = + all (Seq.isValid applyTestDelta) (Seq.suffixes seq) + === True + +-------------------------------------------------------------------------------- +-- Test states +-------------------------------------------------------------------------------- + +newtype TestState = TestState {unTestState :: Int} + deriving (Eq, Generic, Show) + +genTestState :: Gen TestState +genTestState = TestState <$> choose (0, 3) + +shrinkTestState :: TestState -> [TestState] +shrinkTestState = shrinkMapBy TestState unTestState shrink + +-------------------------------------------------------------------------------- +-- Test delta functions +-------------------------------------------------------------------------------- + +data TestDeltaFn + = Add + | Sub + | Mul + deriving (Bounded, Enum, Eq, Generic, Show) + +applyTestDeltaFn :: TestDeltaFn -> (Int -> Int -> Int) +applyTestDeltaFn = \case + Add -> (+) + Sub -> (-) + Mul -> (*) + +genTestDeltaFn :: Gen TestDeltaFn +genTestDeltaFn = arbitraryBoundedEnum + +shrinkTestDeltaFn :: TestDeltaFn -> [TestDeltaFn] +shrinkTestDeltaFn = genericShrink + +-------------------------------------------------------------------------------- +-- Test deltas +-------------------------------------------------------------------------------- + +data TestDelta = TestDelta TestDeltaFn Int + deriving (Eq, Generic, Show) + +applyTestDelta :: TestState -> TestDelta -> TestState +applyTestDelta (TestState i) (TestDelta fn j) = + TestState $ applyTestDeltaFn fn i j + +genTestDelta :: Gen TestDelta +genTestDelta = TestDelta + <$> genTestDeltaFn + <*> choose (0, 3) + +shrinkTestDelta :: TestDelta -> [TestDelta] +shrinkTestDelta = genericShrink + +-------------------------------------------------------------------------------- +-- Test state delta sequences +-------------------------------------------------------------------------------- + +newtype TestStateDeltaSeq = TestStateDeltaSeq + {unTestStateDeltaSeq :: StateDeltaSeq TestState TestDelta} + deriving (Eq, Show) + +genTestStateDeltaSeq :: Gen TestStateDeltaSeq +genTestStateDeltaSeq = + fmap TestStateDeltaSeq . Seq.fromStateDeltas applyTestDelta + <$> genTestState + <*> listOf genTestDelta + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance (Arbitrary s, Arbitrary d) => Arbitrary (StateDeltaSeq s d) where + arbitrary = Seq.fromStateDeltasUnchecked + <$> arbitrary @s + <*> arbitrary @([(d, s)]) + +instance Arbitrary TestStateDeltaSeq where + arbitrary = genTestStateDeltaSeq + +instance Arbitrary TestDeltaFn where + arbitrary = genTestDeltaFn + shrink = shrinkTestDeltaFn + +instance Arbitrary TestState where + arbitrary = genTestState + shrink = shrinkTestState + +instance Arbitrary TestDelta where + arbitrary = genTestDelta + shrink = shrinkTestDelta + +deriving anyclass instance CoArbitrary TestDelta +deriving anyclass instance CoArbitrary TestDeltaFn + +deriving anyclass instance Function TestDelta +deriving anyclass instance Function TestDeltaFn + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +consecutivePairs :: Foldable f => f a -> [(a, a)] +consecutivePairs (F.toList -> xs) = case tailMay xs of + Nothing -> [] + Just ys -> xs `zip` ys + +removeConsecutiveDuplicates :: (Foldable f, Eq a) => f a -> [a] +removeConsecutiveDuplicates = loop . F.toList + where + loop = \case + [ ] -> [ ] + [a] -> [a] + (a1 : a2 : as) + | a1 == a2 -> loop (a2 : as) + | otherwise -> a1 : loop (a2 : as) + +strictlyIncreasing :: (Foldable f, Ord a) => f a -> Bool +strictlyIncreasing as = all (uncurry (<)) (consecutivePairs as)