diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,20 @@ # Changelog -## [Unreleased] +## [0.4.0.0] - 2021-11-21 +### Changed + +* Compatibility with `genvalidity >=1.0.0.0` + ## [0.3.0.0] - 2020-02-14 +### Added + * Benchmarks for cursor generation ## [0.2.0.0] - 2019-09-23 + +### Changed * Fixed the generator for `TextFieldCursor` to be compatible with the new validity constraint in cursor-0.2.0.0. * Fixed the shrinking function for `TextFieldCursor`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018 Tom Sydney Kerckhove +Copyright (c) 2018-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -3,42 +3,39 @@ module Main where import Criterion.Main as Criterion - -import Data.GenValidity.Criterion - import Cursor.Forest.Gen () +import Cursor.List import Cursor.List.Gen () import Cursor.List.NonEmpty.Gen () import Cursor.Map.Gen () import Cursor.Map.KeyValue.Gen () -import Cursor.Text.Gen () -import Cursor.TextField.Gen () -import Cursor.Tree.Gen () - -import Cursor.List import Cursor.Simple.Forest import Cursor.Simple.List.NonEmpty import Cursor.Simple.Map import Cursor.Simple.Tree import Cursor.Text +import Cursor.Text.Gen () import Cursor.TextField +import Cursor.TextField.Gen () +import Cursor.Tree.Gen () +import Data.GenValidity.Criterion main :: IO () main = Criterion.defaultMain - [ genValidBench @(ListCursor Bool) - , genValidBench @(NonEmptyCursor Bool) - , genValidBench @(KeyValueCursor Bool Bool) - , genValidBench @(MapCursor Bool Bool) - , genValidBench @(SwapResult Bool) - , genValidBench @(PromoteElemResult Bool) - , genValidBench @(PromoteResult Bool) - , genValidBench @(DemoteResult Bool) - , genValidBench @(CTree Bool) - , genValidBench @(CForest Bool) - , genValidBench @(TreeAbove Bool) - , genValidBench @(TreeCursor Bool) - , genValidBench @(ForestCursor Bool) - , genValidBench @TextCursor - , genValidBench @TextFieldCursor + [ genValidBench @(ListCursor Bool), + genValidBench @(NonEmptyCursor Bool), + genValidBench @(KeyValueCursor Bool Bool), + genValidBench @(MapCursor Bool Bool), + genValidBench @(SwapResult Bool), + genValidBench @(PromoteElemResult Bool), + genValidBench @(PromoteResult Bool), + genValidBench @(DemoteResult Bool), + genValidBench @(CTree Bool), + genValidBench @(CForest Bool), + genValidBench @(TreeAbove Bool), + genValidBench @(TreeCursor Bool), + genValidBench @(ForestCursor Bool), + genValidBench @TextCursor, + genValidBench @TextFieldCursor ] diff --git a/cursor-gen.cabal b/cursor-gen.cabal --- a/cursor-gen.cabal +++ b/cursor-gen.cabal @@ -1,20 +1,20 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: ca8f0d880d4a2aa40bc3c0de55b6c000b047b412f701f38af7d0da3f5c4346a2 +-- hash: 22ff370fec49a2935a5592601cfd45bcdce55a0343352c14841cc1d09ceb9de8 name: cursor-gen -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Generators for Purely Functional Cursors description: Generators for Purely Functional Cursors for common data structures category: Cursor homepage: https://github.com/NorfairKing/cursor author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2018 Tom Sydney Kerckhove +copyright: Copyright: (c) 2018-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple diff --git a/src/Cursor/Forest/Gen.hs b/src/Cursor/Forest/Gen.hs --- a/src/Cursor/Forest/Gen.hs +++ b/src/Cursor/Forest/Gen.hs @@ -2,19 +2,14 @@ module Cursor.Forest.Gen ( - ) where - -import Data.GenValidity -import Data.GenValidity.Containers () + ) +where import Cursor.Forest - import Cursor.List.NonEmpty.Gen () import Cursor.Tree.Gen () - -instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (ForestCursor a b) where - genUnchecked = ForestCursor <$> genUnchecked - shrinkUnchecked (ForestCursor ne) = ForestCursor <$> shrinkUnchecked ne +import Data.GenValidity +import Data.GenValidity.Containers () instance (GenValid a, GenValid b) => GenValid (ForestCursor a b) where genValid = ForestCursor <$> genValid diff --git a/src/Cursor/List/Gen.hs b/src/Cursor/List/Gen.hs --- a/src/Cursor/List/Gen.hs +++ b/src/Cursor/List/Gen.hs @@ -2,25 +2,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.List.Gen - ( listCursorWithGen - , listCursorWithIndex0 - ) where - -import Test.QuickCheck + ( listCursorWithGen, + listCursorWithIndex0, + ) +where import Cursor.List - import Data.GenValidity - -instance GenUnchecked a => GenUnchecked (ListCursor a) where - genUnchecked = - sized $ \n -> do - (a, b) <- genSplit n - listCursorPrev <- resize a genUnchecked - listCursorNext <- resize b genUnchecked - pure ListCursor {..} - shrinkUnchecked (ListCursor prev next) = - [ListCursor prev' next' | (prev', next') <- shrinkUnchecked (prev, next)] +import Test.QuickCheck instance GenValid a => GenValid (ListCursor a) where genValid = diff --git a/src/Cursor/List/NonEmpty/Gen.hs b/src/Cursor/List/NonEmpty/Gen.hs --- a/src/Cursor/List/NonEmpty/Gen.hs +++ b/src/Cursor/List/NonEmpty/Gen.hs @@ -2,26 +2,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.List.NonEmpty.Gen - ( genNonEmptyCursorBy - , nonEmptyElemOf - , nonEmptyWithIndex0 - , nonEmptyWith - ) where + ( genNonEmptyCursorBy, + nonEmptyElemOf, + nonEmptyWithIndex0, + nonEmptyWith, + ) +where import Control.Monad - +import Cursor.List.NonEmpty import Data.GenValidity - -import Test.QuickCheck - import qualified Data.List.NonEmpty as NE - -import Cursor.List.NonEmpty - -instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (NonEmptyCursor a b) where - genUnchecked = genNonEmptyCursorBy genUnchecked genUnchecked - shrinkUnchecked (NonEmptyCursor prev cur next) = - [NonEmptyCursor prev' cur' next' | (prev', cur', next') <- shrinkUnchecked (prev, cur, next)] +import Test.QuickCheck instance (GenValid a, GenValid b) => GenValid (NonEmptyCursor a b) where genValid = genNonEmptyCursorBy genValid genValid @@ -34,7 +26,7 @@ part <- arbPartition n case part of [] -> singletonNonEmptyCursor <$> resize 0 genA - (s:ss) -> do + (s : ss) -> do i <- choose (0, length ss) let (as, bs) = splitAt i ss nonEmptyCursorPrev <- forM as $ \s_ -> resize s_ genB @@ -51,9 +43,9 @@ nonEmptyWith :: a -> Gen a -> Gen (NonEmptyCursor a a) nonEmptyWith a g = oneof - [ NonEmptyCursor <$> listWithA <*> g <*> genListOf g - , NonEmptyCursor <$> genListOf g <*> pure a <*> genListOf g - , NonEmptyCursor <$> genListOf g <*> g <*> listWithA + [ NonEmptyCursor <$> listWithA <*> g <*> genListOf g, + NonEmptyCursor <$> genListOf g <*> pure a <*> genListOf g, + NonEmptyCursor <$> genListOf g <*> g <*> listWithA ] where listWithA = do diff --git a/src/Cursor/Map/Gen.hs b/src/Cursor/Map/Gen.hs --- a/src/Cursor/Map/Gen.hs +++ b/src/Cursor/Map/Gen.hs @@ -1,28 +1,27 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Map.Gen - ( genMapCursorBy - ) where + ( genMapCursorBy, + genMapCursorByDependent, + ) +where +import Cursor.List.NonEmpty.Gen +import Cursor.Map +import Cursor.Map.KeyValue.Gen import Data.GenValidity import Data.GenValidity.Containers () - import Test.QuickCheck -import Cursor.Map - -import Cursor.List.NonEmpty.Gen -import Cursor.Map.KeyValue.Gen - -instance (GenUnchecked kc, GenUnchecked vc, GenUnchecked k, GenUnchecked v) => - GenUnchecked (MapCursor kc vc k v) where - genUnchecked = genMapCursorBy genUnchecked genUnchecked genUnchecked genUnchecked - instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => GenValid (MapCursor kc vc k v) where genValid = genMapCursorBy genValid genValid genValid genValid shrinkValid = shrinkValidStructurallyWithoutExtraFiltering genMapCursorBy :: Gen kc -> Gen vc -> Gen k -> Gen v -> Gen (MapCursor kc vc k v) genMapCursorBy genKC genVC genK genV = - MapCursor <$> - genNonEmptyCursorBy (genKeyValueCursorBy genKC genVC genK genV) ((,) <$> genK <*> genV) + MapCursor + <$> genNonEmptyCursorBy (genKeyValueCursorBy genKC genVC genK genV) ((,) <$> genK <*> genV) + +genMapCursorByDependent :: Gen (kc, v) -> Gen (k, vc) -> Gen (k, v) -> Gen (MapCursor kc vc k v) +genMapCursorByDependent genKVCK genKVCV genKV = + MapCursor <$> genNonEmptyCursorBy (genKeyValueCursorByDependent genKVCK genKVCV) genKV diff --git a/src/Cursor/Map/KeyValue/Gen.hs b/src/Cursor/Map/KeyValue/Gen.hs --- a/src/Cursor/Map/KeyValue/Gen.hs +++ b/src/Cursor/Map/KeyValue/Gen.hs @@ -1,28 +1,28 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Map.KeyValue.Gen - ( genKeyValueCursorBy - ) where + ( genKeyValueCursorBy, + genKeyValueCursorByDependent, + ) +where +import Cursor.Map.KeyValue import Data.GenValidity - import Test.QuickCheck -import Cursor.Map.KeyValue - -instance (GenUnchecked kc, GenUnchecked vc, GenUnchecked k, GenUnchecked v) => - GenUnchecked (KeyValueCursor kc vc k v) where - genUnchecked = genKeyValueCursorBy genUnchecked genUnchecked genUnchecked genUnchecked - -instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => - GenValid (KeyValueCursor kc vc k v) where +instance + (GenValid kc, GenValid vc, GenValid k, GenValid v) => + GenValid (KeyValueCursor kc vc k v) + where genValid = genKeyValueCursorBy genValid genValid genValid genValid shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked KeyValueToggle - instance GenValid KeyValueToggle genKeyValueCursorBy :: Gen kc -> Gen vc -> Gen k -> Gen v -> Gen (KeyValueCursor kc vc k v) genKeyValueCursorBy genKC genVC genK genV = oneof [KeyValueCursorKey <$> genKC <*> genV, KeyValueCursorValue <$> genK <*> genVC] + +genKeyValueCursorByDependent :: Gen (kc, v) -> Gen (k, vc) -> Gen (KeyValueCursor kc vc k v) +genKeyValueCursorByDependent genKVCK genKVCV = + oneof [uncurry KeyValueCursorKey <$> genKVCK, uncurry KeyValueCursorValue <$> genKVCV] diff --git a/src/Cursor/Simple/Forest/Gen.hs b/src/Cursor/Simple/Forest/Gen.hs --- a/src/Cursor/Simple/Forest/Gen.hs +++ b/src/Cursor/Simple/Forest/Gen.hs @@ -1,5 +1,6 @@ module Cursor.Simple.Forest.Gen ( - ) where + ) +where import Cursor.Forest.Gen () diff --git a/src/Cursor/Simple/List/NonEmpty/Gen.hs b/src/Cursor/Simple/List/NonEmpty/Gen.hs --- a/src/Cursor/Simple/List/NonEmpty/Gen.hs +++ b/src/Cursor/Simple/List/NonEmpty/Gen.hs @@ -1,13 +1,13 @@ module Cursor.Simple.List.NonEmpty.Gen - ( nonEmptyElemOf - , nonEmptyWithIndex0 - , nonEmptyWith - ) where - -import Test.QuickCheck + ( nonEmptyElemOf, + nonEmptyWithIndex0, + nonEmptyWith, + ) +where import qualified Cursor.List.NonEmpty.Gen as NEC import Cursor.Simple.List.NonEmpty +import Test.QuickCheck nonEmptyElemOf :: NonEmptyCursor a -> Gen a nonEmptyElemOf = NEC.nonEmptyElemOf diff --git a/src/Cursor/Simple/Map/Gen.hs b/src/Cursor/Simple/Map/Gen.hs --- a/src/Cursor/Simple/Map/Gen.hs +++ b/src/Cursor/Simple/Map/Gen.hs @@ -1,5 +1,6 @@ module Cursor.Simple.Map.Gen ( - ) where + ) +where import Cursor.Map.Gen () diff --git a/src/Cursor/Simple/Map/KeyValue/Gen.hs b/src/Cursor/Simple/Map/KeyValue/Gen.hs --- a/src/Cursor/Simple/Map/KeyValue/Gen.hs +++ b/src/Cursor/Simple/Map/KeyValue/Gen.hs @@ -1,5 +1,6 @@ module Cursor.Simple.Map.KeyValue.Gen ( - ) where + ) +where import Cursor.Map.KeyValue.Gen () diff --git a/src/Cursor/Simple/Tree/Gen.hs b/src/Cursor/Simple/Tree/Gen.hs --- a/src/Cursor/Simple/Tree/Gen.hs +++ b/src/Cursor/Simple/Tree/Gen.hs @@ -1,5 +1,6 @@ module Cursor.Simple.Tree.Gen ( - ) where + ) +where import Cursor.Tree.Gen () diff --git a/src/Cursor/Text/Gen.hs b/src/Cursor/Text/Gen.hs --- a/src/Cursor/Text/Gen.hs +++ b/src/Cursor/Text/Gen.hs @@ -1,23 +1,23 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Text.Gen - ( genSafeChar - , genTextCursorChar - , textCursorWithGen - , textCursorWithIndex0 - ) where - -import Test.QuickCheck - -import Data.GenValidity -import Data.GenValidity.Text () + ( genSafeChar, + genTextCursorChar, + textCursorSentenceGen, + textCursorWithGen, + textCursorWithIndex0, + shrinkSentence, + ) +where +import Cursor.List +import Cursor.List.Gen import Cursor.Text import Cursor.Types - -import Cursor.List.Gen - -instance GenUnchecked TextCursor +import Data.Char (isSpace) +import Data.GenValidity +import Data.GenValidity.Text () +import Test.QuickCheck instance GenValid TextCursor where genValid = TextCursor <$> listCursorWithGen genTextCursorChar @@ -26,6 +26,9 @@ genSafeChar :: Gen Char genSafeChar = choose (minBound, maxBound) `suchThat` isSafeChar +genSpaceChar :: Gen Char +genSpaceChar = elements [' ', '\t', '\v'] + genTextCursorChar :: Gen Char genTextCursorChar = genSafeChar `suchThat` (/= '\n') @@ -34,3 +37,18 @@ textCursorWithIndex0 :: Gen Char -> Gen TextCursor textCursorWithIndex0 gen = TextCursor <$> listCursorWithIndex0 gen + +textCursorSentenceGen :: Gen TextCursor +textCursorSentenceGen = textCursorWithGen sentenceGen + where + sentenceGen :: Gen Char + sentenceGen = frequency [(1, genSpaceChar), (5, genSafeChar)] + +shrinkSentence :: TextCursor -> [TextCursor] +shrinkSentence tc@(TextCursor (ListCursor before after)) = + filter (/= tc) [TextCursor (ListCursor (map f before) (map f after))] + where + f :: Char -> Char + f x + | isSpace x = ' ' + | otherwise = 'a' diff --git a/src/Cursor/TextField/Gen.hs b/src/Cursor/TextField/Gen.hs --- a/src/Cursor/TextField/Gen.hs +++ b/src/Cursor/TextField/Gen.hs @@ -2,16 +2,13 @@ module Cursor.TextField.Gen where -import Data.GenValidity -import Data.GenValidity.Text - -import Test.QuickCheck - import Cursor.List.NonEmpty -import Cursor.TextField - import Cursor.List.NonEmpty.Gen () import Cursor.Text.Gen +import Cursor.TextField +import Data.GenValidity +import Data.GenValidity.Text +import Test.QuickCheck instance GenValid TextFieldCursor where genValid = diff --git a/src/Cursor/Tree/Gen.hs b/src/Cursor/Tree/Gen.hs --- a/src/Cursor/Tree/Gen.hs +++ b/src/Cursor/Tree/Gen.hs @@ -4,57 +4,35 @@ module Cursor.Tree.Gen ( - ) where - -import qualified Data.List.NonEmpty as NE -import Data.Maybe + ) +where +import Cursor.Tree import Data.GenValidity import Data.GenValidity.Containers () - +import qualified Data.List.NonEmpty as NE import Test.QuickCheck -import Cursor.Tree - -instance GenUnchecked TreeCursorSelection - instance GenValid TreeCursorSelection where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (SwapResult a) - instance GenValid a => GenValid (SwapResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (PromoteElemResult a) - instance GenValid a => GenValid (PromoteElemResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (PromoteResult a) - instance GenValid a => GenValid (PromoteResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (DemoteResult a) - instance GenValid a => GenValid (DemoteResult a) where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -instance GenUnchecked a => GenUnchecked (CTree a) where - genUnchecked = - sized $ \n -> do - (a, b) <- genSplit n - val <- resize a genUnchecked - for <- resize b genUnchecked - pure $ CNode val for - shrinkUnchecked (CNode a cf) = [CNode a' cf' | (a', cf') <- shrinkUnchecked (a, cf)] - instance GenValid a => GenValid (CTree a) where genValid = sized $ \n -> do @@ -64,16 +42,6 @@ pure $ CNode val for shrinkValid (CNode a cf) = [CNode a' cf' | (a', cf') <- shrinkValid (a, cf)] -instance GenUnchecked a => GenUnchecked (CForest a) where - genUnchecked = - sized $ \case - 0 -> pure EmptyCForest - _ -> oneof [ClosedForest <$> genUnchecked, OpenForest <$> genUnchecked] - shrinkUnchecked EmptyCForest = [] - shrinkUnchecked (ClosedForest ne) = EmptyCForest : (ClosedForest <$> shrinkUnchecked ne) - shrinkUnchecked (OpenForest ne) = - EmptyCForest : ClosedForest (NE.map rebuildCTree ne) : (OpenForest <$> shrinkUnchecked ne) - instance GenValid a => GenValid (CForest a) where genValid = sized $ \case @@ -84,23 +52,6 @@ shrinkValid (OpenForest ne) = EmptyCForest : ClosedForest (NE.map rebuildCTree ne) : (OpenForest <$> shrinkValid ne) -instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (TreeCursor a b) where - genUnchecked = - sized $ \n -> do - s <- upTo n - (a, b, c, d) <- genSplit4 s - treeAbove <- resize (a + b) genUnchecked - treeCurrent <- resize c genUnchecked - treeBelow <- resize d genUnchecked - pure TreeCursor {..} - shrinkUnchecked tc = - let opts = - catMaybes - [ do ta <- treeAbove tc - pure $ tc {treeAbove = treeAboveAbove ta} - ] - in opts ++ genericShrinkUnchecked tc - instance (GenValid a, GenValid b) => GenValid (TreeCursor a b) where genValid = sized $ \n -> do @@ -111,17 +62,6 @@ treeBelow <- resize d genValid pure TreeCursor {..} shrinkValid = shrinkValidStructurallyWithoutExtraFiltering - -instance GenUnchecked b => GenUnchecked (TreeAbove b) where - genUnchecked = - sized $ \n -> do - s <- upTo n - (a, b, c, d) <- genSplit4 s - treeAboveLefts <- resize a genUnchecked - treeAboveAbove <- resize b genUnchecked - treeAboveNode <- resize c genUnchecked - treeAboveRights <- resize d genUnchecked - pure TreeAbove {..} instance GenValid b => GenValid (TreeAbove b) where genValid = diff --git a/test/Cursor/List/NonEmptySpec.hs b/test/Cursor/List/NonEmptySpec.hs --- a/test/Cursor/List/NonEmptySpec.hs +++ b/test/Cursor/List/NonEmptySpec.hs @@ -2,25 +2,24 @@ {-# LANGUAGE RankNTypes #-} module Cursor.List.NonEmptySpec - ( spec - ) where + ( spec, + ) +where +import Cursor.List.NonEmpty +import qualified Data.List.NonEmpty as NE import Test.Hspec import Test.Validity -import qualified Data.List.NonEmpty as NE - -import Cursor.List.NonEmpty - spec :: Spec spec = do describe "nonemptyPrepend" $ it "is equivalent to regular prepend" $ - equivalentWhenFirstSucceeds - (\(ls1, ls2) -> NE.toList . nonemptyPrepend ls1 <$> NE.nonEmpty ls2) - (uncurry (++) :: ([Bool], [Bool]) -> [Bool]) + equivalentWhenFirstSucceeds + (\(ls1, ls2) -> NE.toList . nonemptyPrepend ls1 <$> NE.nonEmpty ls2) + (uncurry (++) :: ([Bool], [Bool]) -> [Bool]) describe "nonemptyAppend" $ it "is equivalent to regular append" $ - equivalentWhenFirstSucceeds - (\(ls1, ls2) -> NE.toList . (`nonemptyAppend` ls2) <$> NE.nonEmpty ls1) - (uncurry (++) :: ([Bool], [Bool]) -> [Bool]) + equivalentWhenFirstSucceeds + (\(ls1, ls2) -> NE.toList . (`nonemptyAppend` ls2) <$> NE.nonEmpty ls1) + (uncurry (++) :: ([Bool], [Bool]) -> [Bool]) diff --git a/test/Cursor/ListSpec.hs b/test/Cursor/ListSpec.hs --- a/test/Cursor/ListSpec.hs +++ b/test/Cursor/ListSpec.hs @@ -1,19 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Cursor.ListSpec - ( spec - ) where - -import Test.Hspec -import Test.QuickCheck -import Test.Validity + ( spec, + ) +where import Control.Monad - import Cursor.List import Cursor.List.Gen () +import Test.Hspec +import Test.QuickCheck +import Test.Validity spec :: Spec spec = do @@ -22,70 +21,103 @@ genValidSpec @(ListCursor Bool) describe "emptyListCursor" $ it "is valid" $ shouldBeValid (emptyListCursor @Bool) describe "makeListCursor" $ - it "produces valid list cursors" $ producesValidsOnValids (makeListCursor @Bool) + it "produces valid list cursors" $ + producesValid (makeListCursor @Bool) describe "makeListCursorWithSelection" $ - it "produces valid list cursors" $ producesValidsOnValids2 (makeListCursorWithSelection @Bool) + it "produces valid list cursors" $ + producesValid2 (makeListCursorWithSelection @Bool) describe "rebuildListCursor" $ do - it "produces valid lists" $ producesValidsOnValids (rebuildListCursor @Bool) + it "produces valid lists" $ producesValid (rebuildListCursor @Bool) it "is the inverse of makeListCursor" $ inverseFunctions (makeListCursor @Bool) rebuildListCursor it "is the inverse of makeListCursorWithSelection for any index" $ - forAllUnchecked $ \i -> - inverseFunctionsIfFirstSucceeds (makeListCursorWithSelection @Bool i) rebuildListCursor + forAllValid $ + \i -> + inverseFunctionsIfFirstSucceeds (makeListCursorWithSelection @Bool i) rebuildListCursor describe "listCursorNull" $ - it "produces valid bools" $ producesValidsOnValids (listCursorNull @Bool) + it "produces valid bools" $ + producesValid (listCursorNull @Bool) describe "listCursorLength" $ - it "produces valid bools" $ producesValidsOnValids (listCursorLength @Bool) + it "produces valid bools" $ + producesValid (listCursorLength @Bool) describe "listCursorIndex" $ - it "produces valid indices" $ producesValidsOnValids (listCursorIndex @Bool) + it "produces valid indices" $ + producesValid (listCursorIndex @Bool) describe "listCursorSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids (listCursorSelectPrev @Bool) + it "produces valid cursors" $ producesValid (listCursorSelectPrev @Bool) it "is a movement" $ isMovementM listCursorSelectPrev it "selects the previous position" pending describe "listCursorSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids (listCursorSelectNext @Bool) + it "produces valid cursors" $ producesValid (listCursorSelectNext @Bool) it "is a movement" $ isMovementM listCursorSelectNext it "selects the next position" pending describe "listCursorSelectIndex" $ do - it "produces valid cursors" $ producesValidsOnValids2 (listCursorSelectIndex @Bool) - it "is a movement" $ forAllUnchecked $ \ix -> isMovement (listCursorSelectIndex ix) + it "produces valid cursors" $ producesValid2 (listCursorSelectIndex @Bool) + it "is a movement" $ forAllValid $ \ix -> isMovement (listCursorSelectIndex ix) it "selects the position at the given index" pending describe "listCursorPrevItem" $ do - it "produces valid items" $ producesValidsOnValids (listCursorPrevItem @Bool) + it "produces valid items" $ producesValid (listCursorPrevItem @Bool) it "returns the item before the position" pending describe "listCursorNextItem" $ do - it "produces valid items" $ producesValidsOnValids (listCursorNextItem @Bool) + it "produces valid items" $ producesValid (listCursorNextItem @Bool) it "returns the item after the position" pending + describe "listCursorPrevUntil" $ do + it "produces valid cursors" $ producesValid (listCursorPrevUntil @Bool id) + it "produces a cursor where the previous item either satisfies the predicate or is empty" $ + forAllValid $ \cursor -> do + let predicate = id + result = listCursorPrevUntil @Bool predicate cursor + case listCursorPrevItem result of + Just item -> item `shouldSatisfy` predicate + Nothing -> pure () + describe "listCursorNextUntil" $ do + it "produces valid cursors" $ producesValid (listCursorNextUntil @Bool id) + it "produces a cursor where the previous item either satisfies the predicate or is empty" $ + forAllValid $ \cursor -> do + let predicate = id + result = listCursorNextUntil @Bool predicate cursor + case listCursorNextItem result of + Just item -> item `shouldSatisfy` predicate + Nothing -> pure () describe "listCursorSelectStart" $ do - it "produces valid cursors" $ producesValidsOnValids (listCursorSelectStart @Bool) + it "produces valid cursors" $ producesValid (listCursorSelectStart @Bool) it "is a movement" $ isMovement listCursorSelectStart - it "is idempotent" $ idempotentOnValid (listCursorSelectStart @Bool) + it "is idempotent" $ idempotent (listCursorSelectStart @Bool) it "selects the starting position" pending describe "listCursorSelectEnd" $ do - it "produces valid cursors" $ producesValidsOnValids (listCursorSelectEnd @Bool) + it "produces valid cursors" $ producesValid (listCursorSelectEnd @Bool) it "is a movement" $ isMovement listCursorSelectEnd - it "is idempotent" $ idempotentOnValid (listCursorSelectEnd @Bool) + it "is idempotent" $ idempotent (listCursorSelectEnd @Bool) it "selects the end position" pending describe "listCursorInsert" $ do - it "produces valids" $ forAllValid $ \d -> producesValidsOnValids (listCursorInsert @Bool d) + it "produces valids" $ forAllValid $ \d -> producesValid (listCursorInsert @Bool d) it "inserts an item before the cursor" pending describe "listCursorAppend" $ do - it "produces valids" $ forAllValid $ \d -> producesValidsOnValids (listCursorAppend @Bool d) + it "produces valids" $ forAllValid $ \d -> producesValid (listCursorAppend @Bool d) it "inserts an item after the cursor" pending + describe "listCursorInsertList" $ + it "produces valids" $ + forAllValid $ + \d -> producesValid (listCursorInsertList @Bool d) + describe "listCursorAppendList" $ + it "produces valids" $ + forAllValid $ + \d -> producesValid (listCursorAppendList @Bool d) describe "listCursorRemove" $ do - it "produces valids" $ validIfSucceedsOnValid (listCursorRemove @Bool) + it "produces valids" $ validIfSucceeds (listCursorRemove @Bool) it "removes an item before the cursor" pending describe "listCursorDelete" $ do - it "produces valids" $ validIfSucceedsOnValid (listCursorDelete @Bool) + it "produces valids" $ validIfSucceeds (listCursorDelete @Bool) it "removes an item before the cursor" pending describe "listCursorSplit" $ do - it "produces valids" $ producesValidsOnValids (listCursorSplit @Bool) + it "produces valids" $ producesValid (listCursorSplit @Bool) it "produces two list cursors that rebuild to the rebuilding of the original" $ - forAllValid $ \lc -> - let (lc1, lc2) = listCursorSplit (lc :: ListCursor Bool) - in (rebuildListCursor lc1 ++ rebuildListCursor lc2) `shouldBe` rebuildListCursor lc + forAllValid $ + \lc -> + let (lc1, lc2) = listCursorSplit (lc :: ListCursor Bool) + in (rebuildListCursor lc1 ++ rebuildListCursor lc2) `shouldBe` rebuildListCursor lc describe "listCursorCombine" $ do - it "produces valids" $ producesValidsOnValids2 (listCursorCombine @Bool) + it "produces valids" $ producesValid2 (listCursorCombine @Bool) it "produces a list that rebuilds to the rebuilding of the original two cursors" $ forAllValid $ \lc1 -> forAllValid $ \lc2 -> @@ -101,13 +133,13 @@ let ne = rebuildListCursor lec ne' = rebuildListCursor lec' in unless (ne == ne') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show lec - , "List before: \n" ++ show ne - , "Cursor after: \n" ++ show lec' - , "List after: \n" ++ show ne' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show lec, + "List before: \n" ++ show ne, + "Cursor after: \n" ++ show lec', + "List after: \n" ++ show ne' + ] isMovement :: (forall a. ListCursor a -> ListCursor a) -> Property isMovement func = diff --git a/test/Cursor/Map/KeyValueSpec.hs b/test/Cursor/Map/KeyValueSpec.hs --- a/test/Cursor/Map/KeyValueSpec.hs +++ b/test/Cursor/Map/KeyValueSpec.hs @@ -1,15 +1,14 @@ {-# LANGUAGE TypeApplications #-} module Cursor.Map.KeyValueSpec - ( spec - ) where - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Map.KeyValue import Cursor.Map.KeyValue.Gen () +import Test.Hspec +import Test.Validity spec :: Spec spec = do diff --git a/test/Cursor/MapSpec.hs b/test/Cursor/MapSpec.hs --- a/test/Cursor/MapSpec.hs +++ b/test/Cursor/MapSpec.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Cursor.MapSpec - ( spec - ) where - -import Test.Hspec -import Test.Validity + ( spec, + ) +where import Cursor.Map import Cursor.Map.Gen () +import Test.Hspec +import Test.Validity spec :: Spec spec = do diff --git a/test/Cursor/Simple/ForestSpec.hs b/test/Cursor/Simple/ForestSpec.hs --- a/test/Cursor/Simple/ForestSpec.hs +++ b/test/Cursor/Simple/ForestSpec.hs @@ -1,54 +1,57 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.ForestSpec - ( spec - ) where - -import Data.Tree + ( spec, + ) +where import Control.Monad (unless) - -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Test.Validity -import Test.Validity.Optics - -import Cursor.Forest (ForestCursor(..)) +import Cursor.Forest (ForestCursor (..)) import Cursor.List.NonEmpty import Cursor.Simple.Forest hiding (ForestCursor) import qualified Cursor.Simple.Forest as SFC (ForestCursor) +import Cursor.Simple.Forest.Gen () import Cursor.Tree import Cursor.Types - -import Cursor.Simple.Forest.Gen () +import Data.Tree +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.Validity +import Test.Validity.Optics spec :: Spec spec = do eqSpec @(SFC.ForestCursor Int) genValidSpec @(SFC.ForestCursor Bool) modifyMaxSize (`quot` 2) $ - modifyMaxSuccess (`quot` 2) $ shrinkValidSpecWithLimit @(SFC.ForestCursor Bool) 10 + modifyMaxSuccess (`quot` 2) $ + shrinkValidSpecWithLimit @(SFC.ForestCursor Bool) 10 + describe "singletonForestCursor" $ + it "produces valid cursors" $ + producesValid (singletonForestCursor @Bool @Bool) describe "makeForestCursor" $ - it "produces valid cursors" $ producesValidsOnValids (makeForestCursor @Bool) + it "produces valid cursors" $ + producesValid (makeForestCursor @Bool) describe "rebuildForestCursor" $ do - it "produces valid forests" $ producesValidsOnValids (rebuildForestCursor @Bool) + it "produces valid forests" $ producesValid (rebuildForestCursor @Bool) it "is the inverse of makeForestCursor for integers" $ inverseFunctions (makeForestCursor @Int) rebuildForestCursor - describe "forestCursorLestCursorL" $ lensSpecOnValid (forestCursorListCursorL @Bool @Bool) - describe "forestCursorSelectedTreeL" $ lensSpecOnValid (forestCursorSelectedTreeL @Bool @Bool) + describe "forestCursorLestCursorL" $ lensSpec (forestCursorListCursorL @Bool @Bool) + describe "forestCursorSelectedTreeL" $ lensSpec (forestCursorSelectedTreeL @Bool @Bool) describe "forestCursorSelection" $ do - it "produces valid ints" $ producesValidsOnValids (forestCursorSelection @Bool @Bool) + it "produces valid ints" $ producesValid (forestCursorSelection @Bool @Bool) it "returns the index of the currently selected element" pending describe "forestCursorSelectIndex" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorSelectIndex @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorSelectIndex @Bool) it "is the identity function when given the current selection" $ - forAllValid $ \fc -> - forestCursorSelectIndex (forestCursorSelection fc) fc `shouldBe` - Just (fc :: SFC.ForestCursor Bool) + forAllValid $ + \fc -> + forestCursorSelectIndex (forestCursorSelection fc) fc + `shouldBe` Just (fc :: SFC.ForestCursor Bool) it "returns selects the element at the given index" pending movementsSpec collapseSpec @@ -60,254 +63,335 @@ movementsSpec :: Spec movementsSpec = do describe "forestCursorSelectPrevTreeCursor" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectPrevTreeCursor @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectPrevTreeCursor @Bool it "is a movement" $ isMovementM forestCursorSelectPrevTreeCursor it "selects the previous tree cursor" pending describe "forestCursorSelectNextTreeCursor" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectNextTreeCursor @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectNextTreeCursor @Bool it "is a movement" $ isMovementM forestCursorSelectNextTreeCursor it "selects the next tree" pending describe "forestCursorSelectFirstTreeCursor" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectFirstTreeCursor @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectFirstTreeCursor @Bool it "is a movement" $ isMovement forestCursorSelectFirstTreeCursor it "selects the first tree" pending describe "forestCursorSelectLastTreeCursor" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectLastTreeCursor @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectLastTreeCursor @Bool it "is a movement" $ isMovement forestCursorSelectLastTreeCursor it "selects the last tree" pending describe "forestCursorSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectPrev @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectPrev @Bool it "is a movement" $ isMovementM forestCursorSelectPrev it "selects the previous node" pending - -- TODO example with a collapsed tree + -- TODO example with a collapsed tree it "Works for this classic example without any collapsing" $ - -- > 1 - -- > 2 <- expected end cursor - -- > 3 <- start cursor - do - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [CNode 1 $ openForest [CNode 2 emptyCForest]] - , nonEmptyCursorCurrent = - TreeCursor - {treeAbove = Nothing, treeCurrent = 3 :: Int, treeBelow = emptyCForest} - , nonEmptyCursorNext = [] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveAbove = Nothing - , treeAboveLefts = [] - , treeAboveNode = 1 - , treeAboveRights = [] - } - , treeCurrent = 2 - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [CNode 3 emptyCForest] - } - } - case forestCursorSelectPrev start of - Nothing -> expectationFailure "forestCursorSelectPrev should not have failed." - Just actual -> actual `forestShouldBe` expected + -- > 1 + -- > 2 <- expected end cursor + -- > 3 <- start cursor + do + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [CNode 1 $ openForest [CNode 2 emptyCForest]], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 3 :: Int, + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveAbove = Nothing, + treeAboveLefts = [], + treeAboveNode = 1, + treeAboveRights = [] + }, + treeCurrent = 2, + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 3 emptyCForest] + } + } + case forestCursorSelectPrev start of + Nothing -> expectationFailure "forestCursorSelectPrev should not have failed." + Just actual -> actual `forestShouldBe` expected describe "forestCursorSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectNext @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectNext @Bool it "is a movement" $ isMovementM forestCursorSelectNext it "selects the next node" pending it "Works for this classic example" $ - -- > 1 - -- > 2 <- start cursor - -- > 3 <- expected end cursor - do - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveAbove = Nothing - , treeAboveLefts = [] - , treeAboveNode = 1 - , treeAboveRights = [] - } - , treeCurrent = 2 - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [CNode 3 emptyCForest] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [CNode 1 $ openForest [CNode 2 emptyCForest]] - , nonEmptyCursorCurrent = - TreeCursor - {treeAbove = Nothing, treeCurrent = 3 :: Int, treeBelow = emptyCForest} - , nonEmptyCursorNext = [] - } - } - case forestCursorSelectNext start of - Nothing -> expectationFailure "forestCursorSelectNext should not have failed." - Just actual -> actual `forestShouldBe` expected + -- > 1 + -- > 2 <- start cursor + -- > 3 <- expected end cursor + do + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveAbove = Nothing, + treeAboveLefts = [], + treeAboveNode = 1, + treeAboveRights = [] + }, + treeCurrent = 2, + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 3 emptyCForest] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [CNode 1 $ openForest [CNode 2 emptyCForest]], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 3 :: Int, + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [] + } + } + case forestCursorSelectNext start of + Nothing -> expectationFailure "forestCursorSelectNext should not have failed." + Just actual -> actual `forestShouldBe` expected describe "forestCursorSelectPrevOnSameLevel" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectPrevOnSameLevel @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectPrevOnSameLevel @Bool it "is a movement" $ isMovementM forestCursorSelectPrevOnSameLevel it "selects the previous node on the same level as the current node" pending describe "forestCursorSelectNextOnSameLevel" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectNextOnSameLevel @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectNextOnSameLevel @Bool it "is a movement" $ isMovementM forestCursorSelectNextOnSameLevel it "selects the next node on the same level as the current node" pending + describe "forestCursorSelectFirstOnSameLevel" $ do + it "produces valid cursors" $ producesValid $ forestCursorSelectFirstOnSameLevel @Bool + it "is a movement" $ isMovement forestCursorSelectFirstOnSameLevel + it "selects the previous node on the same level as the current node" pending + describe "forestCursorSelectLastOnSameLevel" $ do + it "produces valid cursors" $ producesValid $ forestCursorSelectLastOnSameLevel @Bool + it "is a movement" $ isMovement forestCursorSelectLastOnSameLevel + it "selects the next node on the same level as the current node" pending describe "forestCursorSelectFirst" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectFirst @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectFirst @Bool it "is a movement" $ isMovement forestCursorSelectFirst it "selects the first node in the forest" pending describe "forestCursorSelectLast" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectLast @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectLast @Bool it "is a movement" $ isMovement forestCursorSelectLast it "selects the last node in the forest" pending describe "forestCursorSelectAbove" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectAbove @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectAbove @Bool it "is a movement" $ isMovementM forestCursorSelectAbove it "selects the parent" pending describe "forestCursorSelectBelowAtPos" $ do - it "produces valid cursors" $ producesValidsOnValids2 $ forestCursorSelectBelowAtPos @Bool + it "produces valid cursors" $ producesValid2 $ forestCursorSelectBelowAtPos @Bool it "is a movement for any index" $ - forAllValid $ \i -> isMovementM $ forestCursorSelectBelowAtPos i + forAllValid $ + \i -> isMovementM $ forestCursorSelectBelowAtPos i it "selects the child of the selected node at the given position" pending describe "forestCursorSelectBelowAtStart" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectBelowAtStart @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectBelowAtStart @Bool it "is a movement" $ isMovementM forestCursorSelectBelowAtStart it "selects the first child of the selected node" pending describe "forestCursorSelectBelowAtEnd" $ do - it "produces valid cursors" $ producesValidsOnValids $ forestCursorSelectBelowAtEnd @Bool + it "produces valid cursors" $ producesValid $ forestCursorSelectBelowAtEnd @Bool it "is a movement" $ isMovementM forestCursorSelectBelowAtEnd it "selects the first child of the selected node" pending collapseSpec :: Spec collapseSpec = do describe "forestCursorOpenCurrentForest" $ - it "produces valid cursors" $ producesValidsOnValids $ forestCursorOpenCurrentForest @Bool @Bool + it "produces valid cursors" $ + producesValid $ + forestCursorOpenCurrentForest @Bool @Bool describe "forestCursorCloseCurrentForest" $ it "produces valid cursors" $ - producesValidsOnValids $ forestCursorCloseCurrentForest @Bool @Bool + producesValid $ + forestCursorCloseCurrentForest @Bool @Bool describe "forestCursorToggleCurrentForest" $ it "produces valid cursors" $ - producesValidsOnValids $ forestCursorToggleCurrentForest @Bool @Bool + producesValid $ + forestCursorToggleCurrentForest @Bool @Bool describe "forestCursorOpenCurrentForestRecursively" $ it "produces valid cursors" $ - producesValidsOnValids $ forestCursorToggleCurrentForest @Bool @Bool + producesValid $ + forestCursorToggleCurrentForest @Bool @Bool describe "forestCursorToggleCurrentForestRecursively" $ it "produces valid cursors" $ - producesValidsOnValids $ forestCursorToggleCurrentForestRecursively @Bool @Bool + producesValid $ + forestCursorToggleCurrentForestRecursively @Bool @Bool insertSpec :: Spec insertSpec = do describe "forestCursorInsertEntireTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorInsertEntireTree @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorInsertEntireTree @Bool @Bool) it "inserts a tree cursor before the currently selected tree cursor" pending describe "forestCursorInsertAndSelectTreeCursor" $ do it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorInsertAndSelectTreeCursor @Bool) + producesValid2 (forestCursorInsertAndSelectTreeCursor @Bool) it "inserts a tree cursor before the currently selected tree cursor and selects it" pending describe "forestCursorAppendEntireTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAppendEntireTree @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAppendEntireTree @Bool @Bool) it "appends a tree after the currently selected tree cursor" pending describe "forestCursorAppendAndSelectTreeCursor" $ do it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAppendAndSelectTreeCursor @Bool) + producesValid2 (forestCursorAppendAndSelectTreeCursor @Bool) it "appends a tree cursor after the currently selected tree cursor and selects it" pending describe "forestCursorInsertTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorInsertTree @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorInsertTree @Bool @Bool) it "inserts a tree before the currently selected tree" pending describe "forestCursorInsertAndSelectTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorInsertAndSelectTree @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorInsertAndSelectTree @Bool) it "inserts a tree before the currently selected tree and selects it" pending describe "forestCursorAppendTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAppendTree @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAppendTree @Bool @Bool) it "appends a tree after the currently selected tree " pending describe "forestCursorAppendAndSelectTree" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAppendAndSelectTree @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAppendAndSelectTree @Bool) it "appends a tree after the currently selected tree and selects it" pending describe "forestCursorInsert" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorInsert @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorInsert @Bool @Bool) it "inserts a node before the currently selected node" pending describe "forestCursorInsertAndSelect" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorInsertAndSelect @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorInsertAndSelect @Bool) it "inserts a node before the currently selected node and selects it" pending + describe "forestCursorInsertNodeSingleAndSelect" $ do + it "produces valid cursors" $ producesValid2 (forestCursorInsertNodeSingleAndSelect @Bool) + it "inserts a node before the currently selected node and selects it" pending + describe "forestCursorInsertNodeAndSelect" $ do + it "produces valid cursors" $ producesValid3 (forestCursorInsertNodeAndSelect @Bool) + it "inserts a node before the currently selected node and selects it" pending describe "forestCursorAppend" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAppend @Bool @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAppend @Bool @Bool) it "appends a node after the currently selected node" pending describe "forestCursorAppendAndSelect" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAppendAndSelect @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAppendAndSelect @Bool) it "appends a node after the currently selected node and selects it" pending + describe "forestCursorAppendNodeSingleAndSelect" $ do + it "produces valid cursors" $ producesValid2 (forestCursorAppendNodeSingleAndSelect @Bool) + it "appends a node after the currently selected node and selects it" pending + describe "forestCursorAppendNodeAndSelect" $ do + it "produces valid cursors" $ producesValid3 (forestCursorAppendNodeAndSelect @Bool) + it "appends a node after the currently selected node and selects it" pending describe "forestCursorAddChildTreeToNodeAtPos" $ do it "produces valid cursors" $ - producesValidsOnValids3 $ forestCursorAddChildTreeToNodeAtPos @Bool @Bool + producesValid3 $ + forestCursorAddChildTreeToNodeAtPos @Bool @Bool it "adds a child tree to a node at the given position in the children of that node" pending describe "forestCursorAddChildTreeToNodeAtStart" $ do it "produces valid cursors" $ - producesValidsOnValids2 $ forestCursorAddChildTreeToNodeAtStart @Bool @Bool + producesValid2 $ + forestCursorAddChildTreeToNodeAtStart @Bool @Bool it "adds a child tree to a node at the start the children of that node" pending describe "forestCursorAddChildTreeToNodeAtEnd" $ do it "produces valid cursors" $ - producesValidsOnValids2 $ forestCursorAddChildTreeToNodeAtEnd @Bool @Bool + producesValid2 $ + forestCursorAddChildTreeToNodeAtEnd @Bool @Bool it "adds a child tree to a node at the end the children of that node" pending describe "forestCursorAddChildToNodeAtPos" $ do it "produces valid cursors" $ - producesValidsOnValids3 $ forestCursorAddChildToNodeAtPos @Bool @Bool + producesValid3 $ + forestCursorAddChildToNodeAtPos @Bool @Bool it "adds a child to a node at the given position in the children of that node" pending describe "forestCursorAddChildToNodeAtStart" $ do it "produces valid cursors" $ - producesValidsOnValids2 $ forestCursorAddChildToNodeAtStart @Bool @Bool + producesValid2 $ + forestCursorAddChildToNodeAtStart @Bool @Bool it "adds a child to a node at the start the children of that node" pending describe "forestCursorAddChildToNodeAtEnd" $ do it "produces valid cursors" $ - producesValidsOnValids2 $ forestCursorAddChildToNodeAtEnd @Bool @Bool + producesValid2 $ + forestCursorAddChildToNodeAtEnd @Bool @Bool it "adds a child to a node at the end the children of that node" pending + describe "forestCursorAddChildTreeToNodeAtPosAndSelect" $ do + it "produces valid cursors" $ + producesValid3 $ + forestCursorAddChildTreeToNodeAtPosAndSelect @Bool + it "adds a child tree to a node at the given position in the children of that node" pending + describe "forestCursorAddChildTreeToNodeAtStartAndSelect" $ do + it "produces valid cursors" $ + producesValid2 $ + forestCursorAddChildTreeToNodeAtStartAndSelect @Bool + it "adds a child tree to a node at the start the children of that node" pending + describe "forestCursorAddChildTreeToNodeAtEndAndSelect" $ do + it "produces valid cursors" $ + producesValid2 $ + forestCursorAddChildTreeToNodeAtEndAndSelect @Bool + it "adds a child tree to a node at the end the children of that node" pending + describe "forestCursorAddChildToNodeAtPosAndSelect" $ do + it "produces valid cursors" $ + producesValid3 $ + forestCursorAddChildToNodeAtPosAndSelect @Bool + it "adds a child to a node at the given position in the children of that node" pending + describe "forestCursorAddChildToNodeAtStartAndSelect" $ do + it "produces valid cursors" $ + producesValid2 $ + forestCursorAddChildToNodeAtStartAndSelect @Bool + it "adds a child to a node at the start the children of that node" pending + describe "forestCursorAddChildToNodeAtEndAndSelect" $ do + it "produces valid cursors" $ + producesValid2 $ + forestCursorAddChildToNodeAtEndAndSelect @Bool + it "adds a child to a node at the end the children of that node" pending + describe "forestCursorAddChildNodeSingleToNodeAtPosAndSelect" $ it "produces valid cursors" $ producesValid3 (forestCursorAddChildNodeSingleToNodeAtPosAndSelect @Bool) + describe "forestCursorAddChildNodeSingleToNodeAtStartAndSelect" $ it "produces valid cursors" $ producesValid2 (forestCursorAddChildNodeSingleToNodeAtStartAndSelect @Bool) + describe "forestCursorAddChildNodeSingleToNodeAtEndAndSelect" $ it "produces valid cursors" $ producesValid2 (forestCursorAddChildNodeSingleToNodeAtEndAndSelect @Bool) + describe "forestCursorAddChildNodeToNodeAtPosAndSelect" $ it "produces valid cursors" $ forAllValid $ producesValid3 . (forestCursorAddChildNodeToNodeAtPosAndSelect @Bool) + describe "forestCursorAddChildNodeToNodeAtStartAndSelect" $ it "produces valid cursors" $ producesValid3 (forestCursorAddChildNodeToNodeAtStartAndSelect @Bool) + describe "forestCursorAddChildNodeToNodeAtEndAndSelect" $ it "produces valid cursors" $ producesValid3 (forestCursorAddChildNodeToNodeAtEndAndSelect @Bool) describe "forestCursorAddRoot" $ do - it "produces valid cursors" $ producesValidsOnValids2 (forestCursorAddRoot @Bool) + it "produces valid cursors" $ producesValid2 (forestCursorAddRoot @Bool) it "houses the entire forest under the given node" pending swapSpec :: Spec swapSpec = do describe "forestCursorSwapPrev" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorSwapPrev @Bool @Bool) + it "produces valid cursors" $ producesValid (forestCursorSwapPrev @Bool @Bool) it "works on the example from the docs" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [CNode 'a' emptyCForest] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [CNode 'a' emptyCForest], + nonEmptyCursorCurrent = TreeCursor - {treeAbove = Nothing, treeCurrent = 'b', treeBelow = emptyCForest} - , nonEmptyCursorNext = [] + { treeAbove = Nothing, + treeCurrent = 'b', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [] } } end = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor - {treeAbove = Nothing, treeCurrent = 'b', treeBelow = emptyCForest} - , nonEmptyCursorNext = [CNode 'a' emptyCForest] + { treeAbove = Nothing, + treeCurrent = 'b', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 'a' emptyCForest] } } in case forestCursorSwapPrev start of @@ -315,32 +399,38 @@ Just r -> r `forestShouldBe` end it "swaps the current node with the previous node on the same level" pending it "reverts forestCursorSwapNext" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (forestCursorSwapNext @Bool @Bool) (forestCursorSwapPrev @Bool @Bool) describe "forestCursorSwapNext" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorSwapNext @Bool @Bool) + it "produces valid cursors" $ producesValid (forestCursorSwapNext @Bool @Bool) it "works on the example from the docs" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor - {treeAbove = Nothing, treeCurrent = 'a', treeBelow = emptyCForest} - , nonEmptyCursorNext = [CNode 'b' emptyCForest] + { treeAbove = Nothing, + treeCurrent = 'a', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 'b' emptyCForest] } } end = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [CNode 'b' emptyCForest] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [CNode 'b' emptyCForest], + nonEmptyCursorCurrent = TreeCursor - {treeAbove = Nothing, treeCurrent = 'a', treeBelow = emptyCForest} - , nonEmptyCursorNext = [] + { treeAbove = Nothing, + treeCurrent = 'a', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [] } } in case forestCursorSwapNext start of @@ -348,28 +438,28 @@ Just r -> r `forestShouldBe` end it "swaps the current node with the next node on the same level" pending it "reverts forestCursorSwapPrev" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (forestCursorSwapPrev @Bool @Bool) (forestCursorSwapNext @Bool @Bool) deleteSpec :: Spec deleteSpec = do describe "forestCursorRemoveElemAndSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorRemoveElemAndSelectPrev @Bool) + it "produces valid cursors" $ producesValid (forestCursorRemoveElemAndSelectPrev @Bool) it "works for this simple example" $ forAllValid $ \fs -> let simpleDeleteElemStart = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 :: Int - , treeBelow = closedForest [Node 2 fs] - } - , nonEmptyCursorNext = [] + { treeAbove = Nothing, + treeCurrent = 1 :: Int, + treeBelow = closedForest [Node 2 fs] + }, + nonEmptyCursorNext = [] } } in case forestCursorRemoveElemAndSelectPrev simpleDeleteElemStart of @@ -382,160 +472,163 @@ "forestCursorRemoveElemAndSelectPrev should not have updated the forest cursor, but failed instead." it "removes the selected element and selects the previous element" pending describe "forestCursorDeleteElemAndSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorDeleteElemAndSelectNext @Bool) + it "produces valid cursors" $ producesValid (forestCursorDeleteElemAndSelectNext @Bool) it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 - , treeBelow = closedForest [Node 2 fs] - } - , nonEmptyCursorNext = [] - } - } - simpleDeleteElemExpected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 2 :: Int - , treeBelow = closedForest fs - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorDeleteElemAndSelectNext simpleDeleteElemStart of - Nothing -> - expectationFailure "forestCursorDeleteElemAndSelectNext should not have failed." - Just Deleted -> - expectationFailure - "forestCursorDeleteElemAndSelectNext should not have deleted the entire example forest." - Just (Updated f) -> f `shouldBe` simpleDeleteElemExpected + forAllValid $ + \fs -> + let simpleDeleteElemStart = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 1, + treeBelow = closedForest [Node 2 fs] + }, + nonEmptyCursorNext = [] + } + } + simpleDeleteElemExpected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 2 :: Int, + treeBelow = closedForest fs + }, + nonEmptyCursorNext = [] + } + } + in case forestCursorDeleteElemAndSelectNext simpleDeleteElemStart of + Nothing -> + expectationFailure "forestCursorDeleteElemAndSelectNext should not have failed." + Just Deleted -> + expectationFailure + "forestCursorDeleteElemAndSelectNext should not have deleted the entire example forest." + Just (Updated f) -> f `shouldBe` simpleDeleteElemExpected it "deletes the selected element and selects the next element" pending describe "forestCursorRemoveElem" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorRemoveElem @Bool) + it "produces valid cursors" $ producesValid (forestCursorRemoveElem @Bool) it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 - , treeBelow = closedForest [Node 2 fs] - } - , nonEmptyCursorNext = [] - } - } - simpleDeleteElemExpected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 2 :: Int - , treeBelow = closedForest fs - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorRemoveElem simpleDeleteElemStart of - Deleted -> - expectationFailure - "forestCursorRemoveElem should not have deleted the entire example forest." - Updated f -> f `shouldBe` simpleDeleteElemExpected + forAllValid $ + \fs -> + let simpleDeleteElemStart = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 1, + treeBelow = closedForest [Node 2 fs] + }, + nonEmptyCursorNext = [] + } + } + simpleDeleteElemExpected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 2 :: Int, + treeBelow = closedForest fs + }, + nonEmptyCursorNext = [] + } + } + in case forestCursorRemoveElem simpleDeleteElemStart of + Deleted -> + expectationFailure + "forestCursorRemoveElem should not have deleted the entire example forest." + Updated f -> f `shouldBe` simpleDeleteElemExpected it "removes the selected element" pending describe "forestCursorDeleteElem" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorDeleteElem @Bool) + it "produces valid cursors" $ producesValid (forestCursorDeleteElem @Bool) it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 - , treeBelow = closedForest [Node 2 fs] - } - , nonEmptyCursorNext = [] - } - } - simpleDeleteElemExpected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 2 :: Int - , treeBelow = closedForest fs - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorDeleteElem simpleDeleteElemStart of - Deleted -> - expectationFailure - "forestCursorDeleteElem should not have deleted the entire example forest." - Updated f -> f `shouldBe` simpleDeleteElemExpected + forAllValid $ + \fs -> + let simpleDeleteElemStart = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 1, + treeBelow = closedForest [Node 2 fs] + }, + nonEmptyCursorNext = [] + } + } + simpleDeleteElemExpected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 2 :: Int, + treeBelow = closedForest fs + }, + nonEmptyCursorNext = [] + } + } + in case forestCursorDeleteElem simpleDeleteElemStart of + Deleted -> + expectationFailure + "forestCursorDeleteElem should not have deleted the entire example forest." + Updated f -> f `shouldBe` simpleDeleteElemExpected it "deletes the selected element" pending describe "forestCursorRemoveSubTreeAndSelectPrev" $ do it "produces valid cursors" $ - producesValidsOnValids (forestCursorRemoveSubTreeAndSelectPrev @Bool) + producesValid (forestCursorRemoveSubTreeAndSelectPrev @Bool) it "removes the selected subtree and selects the previous tree" pending describe "forestCursorDeleteSubTreeAndSelectNext" $ do it "produces valid cursors" $ - producesValidsOnValids (forestCursorDeleteSubTreeAndSelectNext @Bool) + producesValid (forestCursorDeleteSubTreeAndSelectNext @Bool) it "deletes the selected subtree and selects the next tree" pending describe "forestCursorRemoveSubTree" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorRemoveSubTree @Bool) + it "produces valid cursors" $ producesValid (forestCursorRemoveSubTree @Bool) it "removes the selected subtree" pending describe "forestCursorDeleteSubTree" $ do - it "produces valid cursors" $ producesValidsOnValids (forestCursorDeleteSubTree @Bool) + it "produces valid cursors" $ producesValid (forestCursorDeleteSubTree @Bool) it "deletes the selected subtree" pending shiftingSpec :: Spec shiftingSpec = do describe "forestCursorPromoteElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ forestCursorPromoteElem @Bool + it "produces valids on valids" $ producesValid $ forestCursorPromoteElem @Bool it "works on the example from the documentation" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]] - , treeAboveAbove = Nothing - , treeAboveNode = 'a' - , treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] - } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] - } - , nonEmptyCursorNext = [CNode 'h' emptyCForest] + { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]], + treeAboveAbove = Nothing, + treeAboveNode = 'a', + treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] + }, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] + }, + nonEmptyCursorNext = [CNode 'h' emptyCForest] } } expected = @@ -544,16 +637,19 @@ NonEmptyCursor { nonEmptyCursorPrev = [ CNode 'a' $ - openForest - [ CNode 'b' $ - openForest [CNode 'c' emptyCForest, CNode 'e' emptyCForest] - , CNode 'f' $ closedForest [Node 'g' []] - ] - ] - , nonEmptyCursorCurrent = + openForest + [ CNode 'b' $ + openForest [CNode 'c' emptyCForest, CNode 'e' emptyCForest], + CNode 'f' $ closedForest [Node 'g' []] + ] + ], + nonEmptyCursorCurrent = TreeCursor - {treeAbove = Nothing, treeCurrent = 'd', treeBelow = emptyCForest} - , nonEmptyCursorNext = [CNode 'h' emptyCForest] + { treeAbove = Nothing, + treeCurrent = 'd', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 'h' emptyCForest] } } in case forestCursorPromoteElem start of @@ -561,41 +657,41 @@ Just f -> f `forestShouldBe` expected it "promotes the current node to the level of its parent" pending describe "forestCursorDemoteElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ forestCursorDemoteElem @Bool + it "produces valids on valids" $ producesValid $ forestCursorDemoteElem @Bool it "works on the example from the documentation" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [CNode 'a' $ closedForest [Node 'b' []]] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [CNode 'a' $ closedForest [Node 'b' []]], + nonEmptyCursorCurrent = TreeCursor - { treeAbove = Nothing - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] - } - , nonEmptyCursorNext = [CNode 'e' emptyCForest] + { treeAbove = Nothing, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] + }, + nonEmptyCursorNext = [CNode 'e' emptyCForest] } } expected = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [CNode 'b' emptyCForest] - , treeAboveAbove = Nothing - , treeAboveNode = 'a' - , treeAboveRights = [CNode 'd' emptyCForest] - } - , treeCurrent = 'c' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [CNode 'e' emptyCForest] + { treeAboveLefts = [CNode 'b' emptyCForest], + treeAboveAbove = Nothing, + treeAboveNode = 'a', + treeAboveRights = [CNode 'd' emptyCForest] + }, + treeCurrent = 'c', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode 'e' emptyCForest] } } in case forestCursorDemoteElem start of @@ -603,27 +699,27 @@ Just f -> f `forestShouldBe` expected it "demotes the current node to the level of its children" pending describe "forestCursorPromoteSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ forestCursorPromoteSubTree @Bool + it "produces valids on valids" $ producesValid $ forestCursorPromoteSubTree @Bool it "works on the example from the documentation" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]] - , treeAboveAbove = Nothing - , treeAboveNode = 'a' - , treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] - } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] - } - , nonEmptyCursorNext = [CNode 'h' emptyCForest] + { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]], + treeAboveAbove = Nothing, + treeAboveNode = 'a', + treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] + }, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] + }, + nonEmptyCursorNext = [CNode 'h' emptyCForest] } } expected = @@ -632,18 +728,18 @@ NonEmptyCursor { nonEmptyCursorPrev = [ CNode 'a' $ - openForest - [ CNode 'b' $ closedForest [Node 'c' []] - , CNode 'f' $ closedForest [Node 'g' []] - ] - ] - , nonEmptyCursorCurrent = + openForest + [ CNode 'b' $ closedForest [Node 'c' []], + CNode 'f' $ closedForest [Node 'g' []] + ] + ], + nonEmptyCursorCurrent = TreeCursor - { treeAbove = Nothing - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] - } - , nonEmptyCursorNext = [CNode 'h' emptyCForest] + { treeAbove = Nothing, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] + }, + nonEmptyCursorNext = [CNode 'h' emptyCForest] } } in case forestCursorPromoteSubTree start of @@ -651,41 +747,41 @@ Just f -> f `forestShouldBe` expected it "promotes the current subtree to the level of its parent" pending describe "forestCursorDemoteSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ forestCursorDemoteSubTree @Bool + it "produces valids on valids" $ producesValid $ forestCursorDemoteSubTree @Bool it "works on the example from the documentation" $ let start = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [CNode 'a' $ closedForest [Node 'b' []]] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [CNode 'a' $ closedForest [Node 'b' []]], + nonEmptyCursorCurrent = TreeCursor - { treeAbove = Nothing - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] - } - , nonEmptyCursorNext = [] + { treeAbove = Nothing, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] + }, + nonEmptyCursorNext = [] } } expected = ForestCursor { forestCursorListCursor = NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [CNode 'b' emptyCForest] - , treeAboveAbove = Nothing - , treeAboveNode = 'a' - , treeAboveRights = [] - } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] - } - , nonEmptyCursorNext = [] + { treeAboveLefts = [CNode 'b' emptyCForest], + treeAboveAbove = Nothing, + treeAboveNode = 'a', + treeAboveRights = [] + }, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] + }, + nonEmptyCursorNext = [] } } in case forestCursorDemoteSubTree start of @@ -694,80 +790,84 @@ it "demotes the current subtree to the level of its children" pending describe "forestCursorDemoteElemUnder" $ do it "produces valids on valids" $ - producesValidsOnValids3 $ forestCursorDemoteElemUnder @Bool @Bool + producesValid3 $ + forestCursorDemoteElemUnder @Bool @Bool it "Works on the example from the docs" $ - forAllValid $ \b1 -> - forAllValid $ \b2 -> - let demoteStart = - ForestCursor $ - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'a' - , treeBelow = closedForest [Node 'b' []] - } - , nonEmptyCursorNext = [] - } - demoteEnd = - ForestCursor $ - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = b1 - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [CNode b2 $ closedForest [Node 'b' []]] - } - in forestCursorDemoteElemUnder b1 b2 demoteStart `forestShouldBe` demoteEnd + forAllValid $ + \b1 -> + forAllValid $ \b2 -> + let demoteStart = + ForestCursor $ + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] + }, + nonEmptyCursorNext = [] + } + demoteEnd = + ForestCursor $ + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = b1, + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = emptyCForest + }, + nonEmptyCursorNext = [CNode b2 $ closedForest [Node 'b' []]] + } + in forestCursorDemoteElemUnder b1 b2 demoteStart `forestShouldBe` demoteEnd it "demotes the current node to the level of its children" pending describe "forestCursorDemoteSubTreeUnder" $ do it "produces valids on valids" $ - producesValidsOnValids2 $ forestCursorDemoteSubTreeUnder @Bool @Bool + producesValid2 $ + forestCursorDemoteSubTreeUnder @Bool @Bool it "Works on the example from the docs" $ - forAllValid $ \v -> do - let demoteStart = - ForestCursor $ - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'a' - , treeBelow = closedForest [Node 'b' []] - } - , nonEmptyCursorNext = [] - } - demoteEnd = - ForestCursor $ - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = v - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = closedForest [Node 'b' []] - } - , nonEmptyCursorNext = [] - } - forestCursorDemoteSubTreeUnder v demoteStart `forestShouldBe` demoteEnd + forAllValid $ + \v -> do + let demoteStart = + ForestCursor $ + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] + }, + nonEmptyCursorNext = [] + } + demoteEnd = + ForestCursor $ + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = v, + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] + }, + nonEmptyCursorNext = [] + } + forestCursorDemoteSubTreeUnder v demoteStart `forestShouldBe` demoteEnd it "demotes the current subtree to the level of its children, by adding a root" pending isMovementM :: (forall a. SFC.ForestCursor a -> Maybe (SFC.ForestCursor a)) -> Property @@ -779,13 +879,13 @@ let ne = rebuildForestCursor lec ne' = rebuildForestCursor lec' in unless (ne == ne') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show lec - , "Forest before: \n" ++ show ne - , "Cursor after: \n" ++ show lec' - , "Forest after: \n" ++ show ne' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show lec, + "Forest before: \n" ++ show ne, + "Cursor after: \n" ++ show lec', + "Forest after: \n" ++ show ne' + ] isMovement :: (forall a. SFC.ForestCursor a -> SFC.ForestCursor a) -> Property isMovement func = @@ -795,11 +895,11 @@ forestShouldBe :: (Show a, Eq a) => SFC.ForestCursor a -> SFC.ForestCursor a -> Expectation forestShouldBe actual expected = unless (actual == expected) $ - expectationFailure $ - unlines - [ "The following should have been equal." - , "actual:" - , drawForestCursor actual - , "expected:" - , drawForestCursor expected - ] + expectationFailure $ + unlines + [ "The following should have been equal.", + "actual:", + drawForestCursor actual, + "expected:", + drawForestCursor expected + ] diff --git a/test/Cursor/Simple/List/NonEmptySpec.hs b/test/Cursor/Simple/List/NonEmptySpec.hs --- a/test/Cursor/Simple/List/NonEmptySpec.hs +++ b/test/Cursor/Simple/List/NonEmptySpec.hs @@ -4,128 +4,143 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.List.NonEmptySpec - ( spec - ) where + ( spec, + ) +where +import Control.Monad +import Cursor.Simple.List.NonEmpty +import Cursor.Simple.List.NonEmpty.Gen import Test.Hspec import Test.QuickCheck import Test.Validity import Test.Validity.Optics -import Control.Monad - -import Cursor.Simple.List.NonEmpty -import Cursor.Simple.List.NonEmpty.Gen - spec :: Spec spec = do eqSpec @(NonEmptyCursor Bool) genValidSpec @(NonEmptyCursor Bool) describe "makeNonEmptyCursor" $ - it "produces valid cursors" $ producesValidsOnValids (makeNonEmptyCursor @Bool) + it "produces valid cursors" $ + producesValid (makeNonEmptyCursor @Bool) describe "makeNonEmptyCursorWithSelection" $ do - it "produces valid cursors" $ producesValidsOnValids2 (makeNonEmptyCursorWithSelection @Bool) + it "produces valid cursors" $ producesValid2 (makeNonEmptyCursorWithSelection @Bool) it "is the inverse of rebuildNonEmptyCursor when using the current selection" $ - forAllValid $ \lec -> - makeNonEmptyCursorWithSelection - (nonEmptyCursorSelection @Bool lec) - (rebuildNonEmptyCursor lec) `shouldBe` - Just lec + forAllValid $ + \lec -> + makeNonEmptyCursorWithSelection + (nonEmptyCursorSelection @Bool lec) + (rebuildNonEmptyCursor lec) + `shouldBe` Just lec describe "singletonNonEmptyCursor" $ - it "produces valid cursors" $ producesValidsOnValids (singletonNonEmptyCursor @Bool @Bool) + it "produces valid cursors" $ + producesValid (singletonNonEmptyCursor @Bool @Bool) describe "rebuildNonEmptyCursor" $ do - it "produces valid nonempty lists" $ producesValidsOnValids (rebuildNonEmptyCursor @Bool) + it "produces valid nonempty lists" $ producesValid (rebuildNonEmptyCursor @Bool) it "is the inverse of makeNonEmptyCursor for integers" $ inverseFunctions (makeNonEmptyCursor @Int) rebuildNonEmptyCursor it "is the inverse of makeNonEmptyCursorWithSelection for integers, for any index" $ - forAll genUnchecked $ \i -> - inverseFunctionsIfFirstSucceedsOnValid + forAllValid $ \i -> + inverseFunctionsIfFirstSucceeds (makeNonEmptyCursorWithSelection @Int i) rebuildNonEmptyCursor - describe "nonEmptyCursorElemL" $ lensSpecOnValid (nonEmptyCursorElemL @Bool @Bool) + describe "nonEmptyCursorElemL" $ lensSpec (nonEmptyCursorElemL @Bool @Bool) describe "nonEmptyCursorSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorSelectPrev @Bool) + it "produces valid cursors" $ producesValid (nonEmptyCursorSelectPrev @Bool) it "is a movement" $ isMovementM nonEmptyCursorSelectPrev it "selects the previous element" pending describe "nonEmptyCursorSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorSelectNext @Bool) + it "produces valid cursors" $ producesValid (nonEmptyCursorSelectNext @Bool) it "is a movement" $ isMovementM nonEmptyCursorSelectNext it "selects the next element" pending describe "nonEmptyCursorSelectFirst" $ do - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorSelectFirst @Bool) + it "produces valid cursors" $ producesValid (nonEmptyCursorSelectFirst @Bool) it "is a movement" $ isMovement nonEmptyCursorSelectFirst - it "is idempotent" $ idempotentOnValid (nonEmptyCursorSelectFirst @Bool) + it "is idempotent" $ idempotent (nonEmptyCursorSelectFirst @Bool) it "selects the first element" pending describe "nonEmptyCursorSelectLast" $ do - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorSelectLast @Bool) + it "produces valid cursors" $ producesValid (nonEmptyCursorSelectLast @Bool) it "is a movement" $ isMovement nonEmptyCursorSelectLast - it "is idempotent" $ idempotentOnValid (nonEmptyCursorSelectLast @Bool) + it "is idempotent" $ idempotent (nonEmptyCursorSelectLast @Bool) it "selects the last element" pending describe "nonEmptyCursorSelection" $ do - it "produces valid ints" $ producesValidsOnValids (nonEmptyCursorSelection @Bool @Bool) + it "produces valid ints" $ producesValid (nonEmptyCursorSelection @Bool @Bool) it "returns the index of the currently selected element" pending describe "nonEmptyCursorSelectIndex" $ do - it "produces valid cursors" $ producesValidsOnValids2 (nonEmptyCursorSelectIndex @Bool) + it "produces valid cursors" $ producesValid2 (nonEmptyCursorSelectIndex @Bool) it "is the identity function when given the current selection" $ forAllValid $ \nec -> - nonEmptyCursorSelectIndex (nonEmptyCursorSelection nec) nec `shouldBe` - Just (nec :: NonEmptyCursor Bool) + nonEmptyCursorSelectIndex (nonEmptyCursorSelection nec) nec + `shouldBe` Just (nec :: NonEmptyCursor Bool) it "returns selects the element at the given index" pending describe "nonEmptyCursorInsert" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorInsert @Bool @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorInsert @Bool @Bool d) it "inserts a character before the cursor" pending describe "nonEmptyCursorAppend" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorAppend @Bool @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorAppend @Bool @Bool d) it "inserts a character after the cursor" pending describe "nonEmptyCursorInsertAndSelect" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorInsertAndSelect @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorInsertAndSelect @Bool d) it "inserts a character before the cursor and selects it" pending describe "nonEmptyCursorAppendAndSelect" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorAppendAndSelect @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorAppendAndSelect @Bool d) it "appends a character before the cursor and selects it" pending describe "nonEmptyCursorInsertAtStart" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorInsertAtStart @Bool @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorInsertAtStart @Bool @Bool d) it "inserts a character at the start of the list" pending describe "nonEmptyCursorAppendAtEnd" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorAppendAtEnd @Bool @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorAppendAtEnd @Bool @Bool d) it "inserts a character at the end of the list" pending describe "nonEmptyCursorInsertAtStartAndSelect" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorInsertAtStartAndSelect @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorInsertAtStartAndSelect @Bool d) it "inserts a character at the start of the list and selects it" pending describe "nonEmptyCursorAppendAtEndAndSelect" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (nonEmptyCursorAppendAtEndAndSelect @Bool d) + forAllValid $ + \d -> producesValid (nonEmptyCursorAppendAtEndAndSelect @Bool d) it "appends a character at the end of the list and selects it" pending describe "nonEmptyCursorRemoveElem" $ do - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorRemoveElem @Bool) + it "produces valid cursors" $ producesValid (nonEmptyCursorRemoveElem @Bool) it "removes an element" pending describe "nonEmptyCursorDeleteElem" $ - it "produces valid cursors" $ producesValidsOnValids (nonEmptyCursorDeleteElem @Bool) + it "produces valid cursors" $ + producesValid (nonEmptyCursorDeleteElem @Bool) describe "nonEmptyCursorSearch" $ do it "produces valid cursors when looking for an equal element" $ - forAllValid $ \a -> producesValidsOnValids $ nonEmptyCursorSearch (== (a :: Bool)) + forAllValid $ + \a -> producesValid $ nonEmptyCursorSearch (== (a :: Bool)) it "is indeed the right value when it finds a value and is looking for an equal element" $ - forAllValid $ \a -> - forAllValid $ \nec -> - case nonEmptyCursorSearch (== (a :: Bool)) nec of - Nothing -> pure () - Just e -> nonEmptyCursorCurrent e `shouldBe` a + forAllValid $ + \a -> + forAllValid $ \nec -> + case nonEmptyCursorSearch (== (a :: Bool)) nec of + Nothing -> pure () + Just e -> nonEmptyCursorCurrent e `shouldBe` a it "finds an element if it is in there" $ - forAllValid $ \a -> - forAll (nonEmptyWith a genValid) $ \nec -> - case nonEmptyCursorSearch (== (a :: Bool)) nec of - Nothing -> expectationFailure "Should not have failed to find the element." - Just e -> nonEmptyCursorCurrent e `shouldBe` a + forAllValid $ + \a -> + forAll (nonEmptyWith a genValid) $ \nec -> + case nonEmptyCursorSearch (== (a :: Bool)) nec of + Nothing -> expectationFailure "Should not have failed to find the element." + Just e -> nonEmptyCursorCurrent e `shouldBe` a describe "nonEmptyCursorSelectOrAdd" $ it "produces valid cursors when looking for an equal element" $ - forAllValid $ \a -> producesValidsOnValids $ nonEmptyCursorSelectOrAdd (== a) (a :: Bool) + forAllValid $ + \a -> producesValid $ nonEmptyCursorSelectOrAdd (== a) (a :: Bool) isMovementM :: (forall a. NonEmptyCursor a -> Maybe (NonEmptyCursor a)) -> Property isMovementM func = @@ -136,13 +151,13 @@ let ne = rebuildNonEmptyCursor lec ne' = rebuildNonEmptyCursor lec' in unless (ne == ne') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show lec - , "List before: \n" ++ show ne - , "Cursor after: \n" ++ show lec' - , "List after: \n" ++ show ne' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show lec, + "List before: \n" ++ show ne, + "Cursor after: \n" ++ show lec', + "List after: \n" ++ show ne' + ] isMovement :: (forall a. NonEmptyCursor a -> NonEmptyCursor a) -> Property isMovement func = diff --git a/test/Cursor/Simple/Map/KeyValueSpec.hs b/test/Cursor/Simple/Map/KeyValueSpec.hs --- a/test/Cursor/Simple/Map/KeyValueSpec.hs +++ b/test/Cursor/Simple/Map/KeyValueSpec.hs @@ -4,41 +4,42 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.Map.KeyValueSpec - ( spec - ) where + ( spec, + ) +where +import Cursor.Simple.Map.KeyValue +import Cursor.Simple.Map.KeyValue.Gen () import Test.Hspec import Test.QuickCheck import Test.Validity -import Cursor.Simple.Map.KeyValue -import Cursor.Simple.Map.KeyValue.Gen () - spec :: Spec spec = do describe "makeKeyValueCursorKey" $ it "produces valid cursors" $ - producesValidsOnValids2 (makeKeyValueCursorKey @Bool @Bool @Bool @Bool) + producesValid2 (makeKeyValueCursorKey @Bool @Bool @Bool @Bool) describe "makeKeyValueCursorValue" $ it "produces valid cursors" $ - producesValidsOnValids2 (makeKeyValueCursorValue @Bool @Bool @Bool @Bool) + producesValid2 (makeKeyValueCursorValue @Bool @Bool @Bool @Bool) describe "rebuildKeyValueCursor" $ - it "produces valid tuples" $ producesValidsOnValids (rebuildKeyValueCursor @Bool @Bool) + it "produces valid tuples" $ + producesValid (rebuildKeyValueCursor @Bool @Bool) describe "keyValueCursorSelection" $ it "produces valid selections" $ - producesValidsOnValids (keyValueCursorSelection @Bool @Bool @Bool @Bool) + producesValid (keyValueCursorSelection @Bool @Bool @Bool @Bool) describe "keyValueCursorSelectKey" $ do - it "produces valid cursors" $ producesValidsOnValids (keyValueCursorSelectKey @Bool @Bool) + it "produces valid cursors" $ producesValid (keyValueCursorSelectKey @Bool @Bool) it "is a movement" $ isMovement keyValueCursorSelectKey describe "keyValueCursorSelectValue" $ do - it "produces valid cursors" $ producesValidsOnValids (keyValueCursorSelectValue @Bool @Bool) + it "produces valid cursors" $ producesValid (keyValueCursorSelectValue @Bool @Bool) it "is a movement" $ isMovement keyValueCursorSelectValue describe "keyValueCursorToggleSelected" $ do - it "produces valid cursors" $ producesValidsOnValids (keyValueCursorToggleSelected @Bool @Bool) + it "produces valid cursors" $ producesValid (keyValueCursorToggleSelected @Bool @Bool) it "is a movement" $ isMovement keyValueCursorToggleSelected isMovement :: (forall k v. KeyValueCursor k v -> KeyValueCursor k v) -> Property isMovement func = forAllValid $ \lec -> - rebuildKeyValueCursor (lec :: KeyValueCursor Bool Bool) `shouldBe` - rebuildKeyValueCursor (func lec) + rebuildKeyValueCursor (lec :: KeyValueCursor Bool Bool) + `shouldBe` rebuildKeyValueCursor (func lec) diff --git a/test/Cursor/Simple/MapSpec.hs b/test/Cursor/Simple/MapSpec.hs --- a/test/Cursor/Simple/MapSpec.hs +++ b/test/Cursor/Simple/MapSpec.hs @@ -1,115 +1,124 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.MapSpec - ( spec - ) where + ( spec, + ) +where +import Control.Monad +import Cursor.Simple.Map +import Cursor.Simple.Map.Gen () +import Lens.Micro import Test.Hspec import Test.QuickCheck import Test.Validity import Test.Validity.Optics -import Lens.Micro - -import Control.Monad - -import Cursor.Simple.Map -import Cursor.Simple.Map.Gen () - spec :: Spec spec = do describe "makeMapCursor" $ - it "produces valid cursors" $ producesValidsOnValids (makeMapCursor @Bool @Bool) + it "produces valid cursors" $ + producesValid (makeMapCursor @Bool @Bool) describe "makeMapCursorWithSelection" $ - it "produces valid cursors" $ producesValidsOnValids2 (makeMapCursorWithSelection @Bool @Bool) + it "produces valid cursors" $ + producesValid2 (makeMapCursorWithSelection @Bool @Bool) describe "singletonMapCursorKey" $ it "produces valid cursors" $ - producesValidsOnValids2 (singletonMapCursorKey @Bool @Bool @Bool @Bool) + producesValid2 (singletonMapCursorKey @Bool @Bool @Bool @Bool) describe "singletonMapCursorValue" $ it "produces valid cursors" $ - producesValidsOnValids2 (singletonMapCursorValue @Bool @Bool @Bool @Bool) + producesValid2 (singletonMapCursorValue @Bool @Bool @Bool @Bool) describe "rebuildMapCursor" $ do - it "produces valid Nonempty lists" $ producesValidsOnValids (rebuildMapCursor @Bool @Bool) + it "produces valid Nonempty lists" $ producesValid (rebuildMapCursor @Bool @Bool) it "is the inverse of makeMapCursor for integers" $ inverseFunctions (makeMapCursor @Bool @Bool) rebuildMapCursor describe "mapCursorNonEmptyCursorL" $ - lensSpecOnValid (mapCursorNonEmptyCursorL @Bool @Bool @Bool @Bool) - describe "mapCursorElemL" $ lensSpecOnValid (mapCursorElemL @Bool @Bool @Bool @Bool) + lensSpec (mapCursorNonEmptyCursorL @Bool @Bool @Bool @Bool) + describe "mapCursorElemL" $ lensSpec (mapCursorElemL @Bool @Bool @Bool @Bool) describe "mapCursorSelectKey" $ - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectKey @Bool @Bool) + it "produces valid cursors" $ + producesValid (mapCursorSelectKey @Bool @Bool) describe "mapCursorSelectValue" $ - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectValue @Bool @Bool) + it "produces valid cursors" $ + producesValid (mapCursorSelectValue @Bool @Bool) describe "mapCursorToggleSelected" $ - it "produces valid cursors" $ producesValidsOnValids (mapCursorToggleSelected @Bool @Bool) + it "produces valid cursors" $ + producesValid (mapCursorToggleSelected @Bool @Bool) describe "mapCursorSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectPrev @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorSelectPrev @Bool @Bool) it "is a movement" $ isMovementM mapCursorSelectPrev it "selects the previous element" pending describe "mapCursorSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectNext @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorSelectNext @Bool @Bool) it "is a movement" $ isMovementM mapCursorSelectNext it "selects the next element" pending describe "mapCursorSelectFirst" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectFirst @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorSelectFirst @Bool @Bool) it "is a movement" $ isMovement mapCursorSelectFirst - it "is idempotent" $ idempotentOnValid (mapCursorSelectFirst @Bool @Bool) + it "is idempotent" $ idempotent (mapCursorSelectFirst @Bool @Bool) it "selects the first element" pending describe "mapCursorSelectLast" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorSelectLast @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorSelectLast @Bool @Bool) it "is a movement" $ isMovement mapCursorSelectLast - it "is idempotent" $ idempotentOnValid (mapCursorSelectLast @Bool @Bool) + it "is idempotent" $ idempotent (mapCursorSelectLast @Bool @Bool) it "selects the last element" pending describe "mapCursorSelection" $ do - it "produces valid ints" $ producesValidsOnValids (mapCursorSelection @Bool @Bool @Bool @Bool) + it "produces valid ints" $ producesValid (mapCursorSelection @Bool @Bool @Bool @Bool) it "returns the index of the currently selected element" pending describe "mapCursorSelectIndex" $ do - it "produces valid cursors" $ producesValidsOnValids2 (mapCursorSelectIndex @Bool @Bool) + it "produces valid cursors" $ producesValid2 (mapCursorSelectIndex @Bool @Bool) it "is the identity function when given the current selection" $ - forAllValid $ \nec -> - mapCursorSelectIndex (mapCursorSelection nec) nec `shouldBe` - Just (nec :: MapCursor Bool Bool) + forAllValid $ + \nec -> + mapCursorSelectIndex (mapCursorSelection nec) nec + `shouldBe` Just (nec :: MapCursor Bool Bool) it "returns selects the element at the given index" pending describe "mapCursorInsert" $ do - it "produces valid cursors" $ producesValidsOnValids3 (mapCursorInsert @Bool @Bool @Bool @Bool) + it "produces valid cursors" $ producesValid3 (mapCursorInsert @Bool @Bool @Bool @Bool) it "inserts a character before the cursor" pending describe "mapCursorAppend" $ do - it "produces valid cursors" $ producesValidsOnValids3 (mapCursorAppend @Bool @Bool @Bool @Bool) + it "produces valid cursors" $ producesValid3 (mapCursorAppend @Bool @Bool @Bool @Bool) it "inserts a character after the cursor" pending describe "mapCursorInsertAndSelectKey" $ - it "produces valid cursors" $ producesValidsOnValids3 (mapCursorInsertAndSelectKey @Bool @Bool) + it "produces valid cursors" $ + producesValid3 (mapCursorInsertAndSelectKey @Bool @Bool) describe "mapCursorAppendAndSelectKey" $ - it "produces valid cursors" $ producesValidsOnValids3 (mapCursorAppendAndSelectKey @Bool @Bool) + it "produces valid cursors" $ + producesValid3 (mapCursorAppendAndSelectKey @Bool @Bool) describe "mapCursorInsertAndSelectValue" $ it "produces valid cursors" $ - producesValidsOnValids3 (mapCursorInsertAndSelectValue @Bool @Bool) + producesValid3 (mapCursorInsertAndSelectValue @Bool @Bool) describe "mapCursorAppendAndSelectValue" $ it "produces valid cursors" $ - producesValidsOnValids3 (mapCursorAppendAndSelectValue @Bool @Bool) + producesValid3 (mapCursorAppendAndSelectValue @Bool @Bool) describe "mapCursorRemoveElem" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorRemoveElem @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorRemoveElem @Bool @Bool) it "removes an element" pending describe "mapCursorDeleteElem" $ do - it "produces valid cursors" $ producesValidsOnValids (mapCursorDeleteElem @Bool @Bool) + it "produces valid cursors" $ producesValid (mapCursorDeleteElem @Bool @Bool) it "deletes an element" pending describe "mapCursorSearch" $ do it "produces valid cursors when looking for an equal pair" $ - forAllValid $ \(k, v) -> - producesValidsOnValids $ mapCursorSearch @Bool @Bool (\k_ v_ -> k_ == k && v_ == v) + forAllValid $ + \(k, v) -> + producesValid $ mapCursorSearch @Bool @Bool (\k_ v_ -> k_ == k && v_ == v) it "is indeed the right value when it finds a value and is looking for an equal element" $ - forAllValid $ \(k, v) -> - forAllValid $ \nec -> - case mapCursorSearch (\k_ v_ -> k_ == k && v_ == v) nec of - Nothing -> pure () - Just e -> rebuildKeyValueCursor (e ^. mapCursorElemL) `shouldBe` (k :: Bool, v :: Bool) + forAllValid $ + \(k, v) -> + forAllValid $ \nec -> + case mapCursorSearch (\k_ v_ -> k_ == k && v_ == v) nec of + Nothing -> pure () + Just e -> rebuildKeyValueCursor (e ^. mapCursorElemL) `shouldBe` (k :: Bool, v :: Bool) describe "mapCursorSelectOrAdd" $ it "produces valid cursors when looking for an equal element" $ - forAllValid $ \(k, v) -> - producesValidsOnValids $ - mapCursorSelectOrAdd - (\k_ v_ -> k_ == k && v_ == v) - (makeKeyValueCursorKey (k :: Bool) (v :: Bool)) + forAllValid $ + \(k, v) -> + producesValid $ + mapCursorSelectOrAdd + (\k_ v_ -> k_ == k && v_ == v) + (makeKeyValueCursorKey (k :: Bool) (v :: Bool)) isMovementM :: (forall k v. MapCursor k v -> Maybe (MapCursor k v)) -> Property isMovementM func = @@ -120,13 +129,13 @@ let ne = rebuildMapCursor lec ne' = rebuildMapCursor lec' in unless (ne == ne') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show lec - , "Map before: \n" ++ show ne - , "Cursor after: \n" ++ show lec' - , "Map after: \n" ++ show ne' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show lec, + "Map before: \n" ++ show ne, + "Cursor after: \n" ++ show lec', + "Map after: \n" ++ show ne' + ] isMovement :: (forall k v. MapCursor k v -> MapCursor k v) -> Property isMovement func = diff --git a/test/Cursor/Simple/Tree/BaseSpec.hs b/test/Cursor/Simple/Tree/BaseSpec.hs --- a/test/Cursor/Simple/Tree/BaseSpec.hs +++ b/test/Cursor/Simple/Tree/BaseSpec.hs @@ -1,39 +1,44 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Simple.Tree.BaseSpec - ( spec - ) where - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import qualified Cursor.Simple.Tree as STC (TreeCursor) import Cursor.Simple.Tree.Gen () - import Cursor.Simple.Tree.TestUtils +import Test.Hspec +import Test.Validity spec :: Spec spec = do eqSpec @(STC.TreeCursor Int) genValidSpec @(STC.TreeCursor Bool) describe "makeTreeCursor" $ - it "produces valid cursors" $ producesValidsOnValids (makeTreeCursor @Bool) + it "produces valid cursors" $ + producesValid (makeTreeCursor @Bool) + describe "makeNodeTreeCursor" $ + it "produces valid cursors" $ + producesValid2 (makeNodeTreeCursor @Bool @Bool) describe "makeTreeCursorWithSelection" $ - it "produces valid cursors" $ producesValidsOnValids2 (makeTreeCursorWithSelection @Bool) + it "produces valid cursors" $ + producesValid2 (makeTreeCursorWithSelection @Bool) describe "singletonTreeCursor" $ - it "produces valid cursors" $ producesValidsOnValids (singletonTreeCursor @Bool) + it "produces valid cursors" $ + producesValid (singletonTreeCursor @Bool) describe "rebuildTreeCursor" $ do - it "produces valid trees" $ producesValidsOnValids (rebuildTreeCursor @Bool) + it "produces valid trees" $ producesValid (rebuildTreeCursor @Bool) it "is the inverse of makeTreeCursor for integers" $ inverseFunctions (makeTreeCursor @Int) rebuildTreeCursor it "is the inverse of makeTreeCursorWithSelection for the current selection" $ - forAllValid $ \tc -> - case makeTreeCursorWithSelection @Bool (treeCursorSelection tc) (rebuildTreeCursor tc) of - Nothing -> expectationFailure "makeTreeCursorWithSelection should not have failed." - Just r -> r `treeShouldBe` tc + forAllValid $ + \tc -> + case makeTreeCursorWithSelection @Bool (treeCursorSelection tc) (rebuildTreeCursor tc) of + Nothing -> expectationFailure "makeTreeCursorWithSelection should not have failed." + Just r -> r `treeShouldBe` tc diff --git a/test/Cursor/Simple/Tree/CollapseSpec.hs b/test/Cursor/Simple/Tree/CollapseSpec.hs --- a/test/Cursor/Simple/Tree/CollapseSpec.hs +++ b/test/Cursor/Simple/Tree/CollapseSpec.hs @@ -1,30 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.CollapseSpec - ( spec - ) where - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () +import Test.Hspec +import Test.Validity spec :: Spec spec = do describe "treeCursorOpenCurrentForest" $ - it "produces valid cursors" $ producesValidsOnValids $ treeCursorOpenCurrentForest @Bool @Bool + it "produces valid cursors" $ + producesValid $ + treeCursorOpenCurrentForest @Bool @Bool describe "treeCursorCloseCurrentForest" $ - it "produces valid cursors" $ producesValidsOnValids $ treeCursorCloseCurrentForest @Bool @Bool + it "produces valid cursors" $ + producesValid $ + treeCursorCloseCurrentForest @Bool @Bool describe "treeCursorToggleCurrentForest" $ - it "produces valid cursors" $ producesValidsOnValids $ treeCursorToggleCurrentForest @Bool @Bool + it "produces valid cursors" $ + producesValid $ + treeCursorToggleCurrentForest @Bool @Bool describe "treeCursorOpenCurrentForestRecursively" $ it "produces valid cursors" $ - producesValidsOnValids $ treeCursorOpenCurrentForestRecursively @Bool @Bool + producesValid $ + treeCursorOpenCurrentForestRecursively @Bool @Bool describe "treeCursorToggleCurrentForestRecursively" $ it "produces valid cursors" $ - producesValidsOnValids $ treeCursorToggleCurrentForestRecursively @Bool @Bool + producesValid $ + treeCursorToggleCurrentForestRecursively @Bool @Bool diff --git a/test/Cursor/Simple/Tree/DeleteSpec.hs b/test/Cursor/Simple/Tree/DeleteSpec.hs --- a/test/Cursor/Simple/Tree/DeleteSpec.hs +++ b/test/Cursor/Simple/Tree/DeleteSpec.hs @@ -1,87 +1,98 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.DeleteSpec - ( spec - ) where - -import Data.Tree - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree (CTree(..), TreeCursor(..), closedForest, openForest) -import Cursor.Types - import Cursor.Simple.Tree.TestUtils +import Cursor.Tree (TreeCursor (..), closedForest, openForest) +import Cursor.Types +import Data.Tree +import Test.Hspec +import Test.Validity spec :: Spec spec = do describe "treeCursorDeleteSubTreeAndSelectPrevious" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteSubTreeAndSelectPrevious @Bool + producesValid $ + treeCursorDeleteSubTreeAndSelectPrevious @Bool it "deletes the current subtree selects the previous subtree" pending describe "treeCursorDeleteSubTreeAndSelectNext" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteSubTreeAndSelectNext @Bool + producesValid $ + treeCursorDeleteSubTreeAndSelectNext @Bool it "deletes the current subtree selects the next subtree" pending describe "treeCursorDeleteSubTreeAndSelectAbove" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteSubTreeAndSelectAbove @Bool + producesValid $ + treeCursorDeleteSubTreeAndSelectAbove @Bool it "deletes the current subtree selects the above node" pending describe "treeCursorRemoveSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorRemoveSubTree @Bool + it "produces valids on valids" $ producesValid $ treeCursorRemoveSubTree @Bool it "removes the current subtree" pending describe "treeCursorDeleteSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorDeleteSubTree @Bool + it "produces valids on valids" $ producesValid $ treeCursorDeleteSubTree @Bool it "deletes the current subtree" pending describe "treeCursorDeleteElemAndSelectPrevious" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElemAndSelectPrevious @Bool + producesValid $ + treeCursorDeleteElemAndSelectPrevious @Bool it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - TreeCursor - {treeAbove = Nothing, treeCurrent = 1 :: Int, treeBelow = closedForest [Node 2 fs]} - in case treeCursorDeleteElemAndSelectPrevious simpleDeleteElemStart of - Nothing -> pure () - Just Deleted -> - expectationFailure - "treeCursorDeleteElemAndSelectPrevious should not have deleted the entire example tree." - Just (Updated _) -> - expectationFailure - "treeCursorDeleteElemAndSelectPrevious should not have updated the example tree, but failed instead." + forAllValid $ + \fs -> + let simpleDeleteElemStart = + TreeCursor + { treeAbove = Nothing, + treeCurrent = 1 :: Int, + treeBelow = closedForest [Node 2 fs] + } + in case treeCursorDeleteElemAndSelectPrevious simpleDeleteElemStart of + Nothing -> pure () + Just Deleted -> + expectationFailure + "treeCursorDeleteElemAndSelectPrevious should not have deleted the entire example tree." + Just (Updated _) -> + expectationFailure + "treeCursorDeleteElemAndSelectPrevious should not have updated the example tree, but failed instead." it "deletes the current element and selects the previous element" pending describe "treeCursorDeleteElemAndSelectNext" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElemAndSelectNext @Bool + producesValid $ + treeCursorDeleteElemAndSelectNext @Bool it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - TreeCursor {treeAbove = Nothing, treeCurrent = 1, treeBelow = openForest [CNode 2 fs]} - simpleDeleteElemExpected = - TreeCursor {treeAbove = Nothing, treeCurrent = 2 :: Int, treeBelow = fs} - in case treeCursorDeleteElemAndSelectNext simpleDeleteElemStart of - Nothing -> - expectationFailure "treeCursorDeleteElemAndSelectNext should not have failed." - Just Deleted -> - expectationFailure - "treeCursorDeleteElemAndSelectNext should not have deleted the entire example tree." - Just (Updated f) -> f `treeShouldBe` simpleDeleteElemExpected + forAllValid $ + \fs -> + let simpleDeleteElemStart = + TreeCursor {treeAbove = Nothing, treeCurrent = 1, treeBelow = openForest [CNode 2 fs]} + simpleDeleteElemExpected = + TreeCursor {treeAbove = Nothing, treeCurrent = 2 :: Int, treeBelow = fs} + in case treeCursorDeleteElemAndSelectNext simpleDeleteElemStart of + Nothing -> + expectationFailure "treeCursorDeleteElemAndSelectNext should not have failed." + Just Deleted -> + expectationFailure + "treeCursorDeleteElemAndSelectNext should not have deleted the entire example tree." + Just (Updated f) -> f `treeShouldBe` simpleDeleteElemExpected it "deletes the current element and selects the next element" pending describe "treeCursorDeleteElemAndSelectAbove" $ do it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElemAndSelectAbove @Bool + producesValid $ + treeCursorDeleteElemAndSelectAbove @Bool it "works for this simple example" $ forAllValid $ \fs -> let simpleDeleteElemStart = TreeCursor - {treeAbove = Nothing, treeCurrent = 1 :: Int, treeBelow = closedForest [Node 2 fs]} + { treeAbove = Nothing, + treeCurrent = 1 :: Int, + treeBelow = closedForest [Node 2 fs] + } in case treeCursorDeleteElemAndSelectAbove simpleDeleteElemStart of Nothing -> pure () Just Deleted -> @@ -92,8 +103,8 @@ "treeCursorDeleteElemAndSelectAbove should not have updated the example tree, but failed instead." it "deletes the current element and selects the above element" pending describe "treeCursorRemoveElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorRemoveElem @Bool + it "produces valids on valids" $ producesValid $ treeCursorRemoveElem @Bool it "removes the current element" pending describe "treeCursorDeleteElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorDeleteElem @Bool + it "produces valids on valids" $ producesValid $ treeCursorDeleteElem @Bool it "deletes the current element" pending diff --git a/test/Cursor/Simple/Tree/DemoteSpec.hs b/test/Cursor/Simple/Tree/DemoteSpec.hs --- a/test/Cursor/Simple/Tree/DemoteSpec.hs +++ b/test/Cursor/Simple/Tree/DemoteSpec.hs @@ -1,169 +1,172 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.DemoteSpec - ( spec - ) where - -import Data.Tree - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree (TreeAbove(..), TreeCursor(..), closedForest, emptyCForest) - import Cursor.Simple.Tree.TestUtils +import Cursor.Tree (TreeCursor (..), closedForest, emptyCForest) +import Data.Tree +import Test.Hspec +import Test.Validity spec :: Spec spec = do functorSpec @DemoteResult describe "treeCursorDemoteElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorDemoteElem @Bool + it "produces valids on valids" $ producesValid $ treeCursorDemoteElem @Bool it "Works on the example from the docs" $ let promoteStart = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'a' [node 'b' []]] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'e' []] - } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] + { treeAboveLefts = [node 'a' [node 'b' []]], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'e' []] + }, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] } promoteEnd = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'b' []] - , treeAboveAbove = + { treeAboveLefts = [node 'b' []], + treeAboveAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'e' []] - } - , treeAboveNode = 'a' - , treeAboveRights = [node 'd' []] - } - , treeCurrent = 'c' - , treeBelow = emptyCForest + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'e' []] + }, + treeAboveNode = 'a', + treeAboveRights = [node 'd' []] + }, + treeCurrent = 'c', + treeBelow = emptyCForest } in case treeCursorDemoteElem promoteStart of Demoted tc' -> tc' `treeShouldBe` promoteEnd _ -> expectationFailure "treeCursorDemoteElem should not have failed" it "demotes the current node to the level of its children" pending describe "treeCursorDemoteSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorDemoteSubTree @Bool + it "produces valids on valids" $ producesValid $ treeCursorDemoteSubTree @Bool it "Works on the example from the docs" $ let promoteStart = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'a' [node 'b' []]] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'e' []] - } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] + { treeAboveLefts = [node 'a' [node 'b' []]], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'e' []] + }, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] } promoteEnd = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'b' []] - , treeAboveAbove = + { treeAboveLefts = [node 'b' []], + treeAboveAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'e' []] - } - , treeAboveNode = 'a' - , treeAboveRights = [] - } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'e' []] + }, + treeAboveNode = 'a', + treeAboveRights = [] + }, + treeCurrent = 'c', + treeBelow = closedForest [Node 'd' []] } in case treeCursorDemoteSubTree promoteStart of Demoted tc' -> tc' `treeShouldBe` promoteEnd _ -> expectationFailure "treeCursorDemoteSubTree should not have failed" it "demotes the current subtree to the level of its children" pending describe "treeCursorDemoteElemUnder" $ do - it "produces valids on valids" $ producesValidsOnValids3 $ treeCursorDemoteElemUnder @Bool @Bool + it "produces valids on valids" $ producesValid3 $ treeCursorDemoteElemUnder @Bool @Bool it "Works on the example from the docs" $ - forAllValid $ \b1 -> - forAllValid $ \b2 -> + forAllValid $ + \b1 -> + forAllValid $ \b2 -> + let demoteStart = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] + } + demoteEnd = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node b2 [node 'b' []]] + }, + treeAboveNode = b1, + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = emptyCForest + } + in case treeCursorDemoteElemUnder b1 b2 demoteStart of + Just tc' -> tc' `treeShouldBe` demoteEnd + _ -> expectationFailure "treeCursorDemoteElemUnder should not have failed" + it "demotes the current node to the level of its children" pending + describe "treeCursorDemoteSubTreeUnder" $ do + it "produces valids on valids" $ + producesValid2 $ + treeCursorDemoteSubTreeUnder @Bool @Bool + it "Works on the example from the docs" $ + forAllValid $ + \v -> do let demoteStart = TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = closedForest [Node 'b' []] + { treeAbove = Nothing, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] } demoteEnd = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node b2 [node 'b' []]] - } - , treeAboveNode = b1 - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = emptyCForest + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = v, + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = closedForest [Node 'b' []] } - in case treeCursorDemoteElemUnder b1 b2 demoteStart of - Just tc' -> tc' `treeShouldBe` demoteEnd - _ -> expectationFailure "treeCursorDemoteElemUnder should not have failed" - it "demotes the current node to the level of its children" pending - describe "treeCursorDemoteSubTreeUnder" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorDemoteSubTreeUnder @Bool @Bool - it "Works on the example from the docs" $ - forAllValid $ \v -> do - let demoteStart = - TreeCursor - {treeAbove = Nothing, treeCurrent = 'a', treeBelow = closedForest [Node 'b' []]} - demoteEnd = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = v - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = closedForest [Node 'b' []] - } - treeCursorDemoteSubTreeUnder v demoteStart `treeShouldBe` demoteEnd + treeCursorDemoteSubTreeUnder v demoteStart `treeShouldBe` demoteEnd it "demotes the current subtree to the level of its children, by adding a root" pending diff --git a/test/Cursor/Simple/Tree/InsertSpec.hs b/test/Cursor/Simple/Tree/InsertSpec.hs --- a/test/Cursor/Simple/Tree/InsertSpec.hs +++ b/test/Cursor/Simple/Tree/InsertSpec.hs @@ -1,39 +1,138 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.InsertSpec - ( spec - ) where - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () +import Cursor.Tree.Types +import Data.Tree +import Test.Hspec +import Test.Validity spec :: Spec spec = do describe "treeCursorInsert" $ do - it "produces valids on valids" $ producesValidsOnValids2 $ treeCursorInsert @Bool @Bool + it "produces valids on valids" $ producesValid2 $ treeCursorInsert @Bool @Bool it "inserts the element" pending describe "treeCursorInsertAndSelect" $ do - it "produces valids on valids" $ producesValidsOnValids2 $ treeCursorInsertAndSelect @Bool + it "produces valids on valids" $ producesValid2 $ treeCursorInsertAndSelect @Bool it "inserts and select the element" pending + describe "treeCursorInsertNodeSingleAndSelect" $ do + it "produces valids on valids" $ producesValid2 $ treeCursorInsertNodeSingleAndSelect @Bool + it "inserts and select the element" pending + describe "treeCursorInsertNodeAndSelect" $ do + it "produces valids on valids" $ producesValid3 $ treeCursorInsertNodeAndSelect @Bool + it "inserts and select the element" pending describe "treeCursorAppend" $ do - it "produces valids on valids" $ producesValidsOnValids2 $ treeCursorAppend @Bool @Bool + it "produces valids on valids" $ producesValid2 $ treeCursorAppend @Bool @Bool it "appends the element" pending describe "treeCursorAppendAndSelect" $ do - it "produces valids on valids" $ producesValidsOnValids2 $ treeCursorAppendAndSelect @Bool + it "produces valids on valids" $ producesValid2 $ treeCursorAppendAndSelect @Bool it "appends and select the element" pending + describe "treeCursorAppendNodeSingleAndSelect" $ do + it "produces valids on valids" $ producesValid2 $ treeCursorAppendNodeSingleAndSelect @Bool + it "appends and select the element" pending + describe "treeCursorAppendNodeAndSelect" $ do + it "produces valids on valids" $ producesValid3 $ treeCursorAppendNodeAndSelect @Bool + it "appends and select the element" pending describe "treeCursorAddChildAtPos" $ do - it "produces valid cursors " $ producesValidsOnValids3 $ treeCursorAddChildAtPos @Bool @Bool + it "produces valid cursors " $ producesValid3 $ treeCursorAddChildAtPos @Bool @Bool it "adds a tree at the given index in the children of the current node" pending describe "treeCursorAddChildAtStart" $ do - it "produces valid cursors " $ producesValidsOnValids2 $ treeCursorAddChildAtStart @Bool @Bool + it "produces valid cursors " $ producesValid2 $ treeCursorAddChildAtStart @Bool @Bool it "adds a tree at the start of the children of the current node" pending describe "treeCursorAddChildAtEnd" $ do - it "produces valid cursors " $ producesValidsOnValids2 $ treeCursorAddChildAtEnd @Bool @Bool + it "produces valid cursors " $ producesValid2 $ treeCursorAddChildAtEnd @Bool @Bool it "adds a tree at the end of the children of the current node" pending + describe "treeCursorAddChildAtPosAndSelect" $ do + it "produces valid cursors " $ producesValid3 $ treeCursorAddChildAtPosAndSelect @Bool + it "adds a tree at the given index in theAndSelect children of the current node" pending + describe "treeCursorAddChildAtStartAndSelect" $ do + it "producesAndSelect valid cursors " $ producesValid2 $ treeCursorAddChildAtStartAndSelect @Bool + it "adds a tree at the start of the children of the current node" pending + describe "treeCursorAddChildAtEndAndSelect" $ do + it "produces valid cursors " $ producesValid2 $ treeCursorAddChildAtEndAndSelect @Bool + it "adds a tree at the end of the children of the current node" pending + describe "treeCursorAddChildNodeSingleAtPosAndSelect" $ it "produces valid cursors" $ producesValid3 (treeCursorAddChildNodeSingleAtPosAndSelect @Bool) + describe "treeCursorAddChildNodeSingleAtStartAndSelect" $ it "produces valid cursors" $ producesValid2 (treeCursorAddChildNodeSingleAtStartAndSelect @Bool) + describe "treeCursorAddChildNodeSingleAtEndAndSelect" $ it "produces valid cursors" $ producesValid2 (treeCursorAddChildNodeSingleAtEndAndSelect @Bool) + describe "treeCursorAddChildNodeAtPosAndSelect" $ it "produces valid cursors" $ forAllValid $ producesValid3 . (treeCursorAddChildNodeAtPosAndSelect @Bool) + describe "treeCursorAddChildNodeAtStartAndSelect" $ do + it "produces valid cursors" $ producesValid3 (treeCursorAddChildNodeAtStartAndSelect @Bool) + it "works for this example" $ + let tc = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = map makeCTree [Node "1" [], Node "2" []], + treeAboveAbove = Nothing, + treeAboveNode = "bar", + treeAboveRights = map makeCTree [Node "3" [], Node "4" []] + }, + treeCurrent = "baz", + treeBelow = makeCForest [Node "a" [], Node "b" []] + } + tc' = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + TreeAbove + { treeAboveLefts = map makeCTree [Node "1" [], Node "2" []], + treeAboveAbove = Nothing, + treeAboveNode = "bar", + treeAboveRights = map makeCTree [Node "3" [], Node "4" []] + }, + treeAboveNode = "baz", + treeAboveRights = map makeCTree [Node "a" [], Node "b" []] + }, + treeCurrent = "new", + treeBelow = makeCForest [] + } + in treeCursorAddChildNodeAtStartAndSelect "new" [] tc `shouldBe` tc' + describe "treeCursorAddChildNodeAtEndAndSelect" $ do + it "produces valid cursors" $ producesValid3 (treeCursorAddChildNodeAtEndAndSelect @Bool) + it "works for this example" $ + let tc = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = map makeCTree [Node "1" [], Node "2" []], + treeAboveAbove = Nothing, + treeAboveNode = "bar", + treeAboveRights = map makeCTree [Node "3" [], Node "4" []] + }, + treeCurrent = "baz", + treeBelow = makeCForest [Node "a" [], Node "b" []] + } + tc' = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = map makeCTree [Node "b" [], Node "a" []], + treeAboveAbove = + Just + TreeAbove + { treeAboveLefts = map makeCTree [Node "1" [], Node "2" []], + treeAboveAbove = Nothing, + treeAboveNode = "bar", + treeAboveRights = map makeCTree [Node "3" [], Node "4" []] + }, + treeAboveNode = "baz", + treeAboveRights = [] + }, + treeCurrent = "new", + treeBelow = makeCForest [] + } + in treeCursorAddChildNodeAtEndAndSelect "new" [] tc `shouldBe` tc' diff --git a/test/Cursor/Simple/Tree/MovementSpec.hs b/test/Cursor/Simple/Tree/MovementSpec.hs --- a/test/Cursor/Simple/Tree/MovementSpec.hs +++ b/test/Cursor/Simple/Tree/MovementSpec.hs @@ -1,238 +1,252 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.MovementSpec - ( spec - ) where + ( spec, + ) +where import Control.Monad (unless) - -import Text.Show.Pretty - -import Test.Hspec - -import Test.Validity - import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree (CTree(..), TreeAbove(..), TreeCursor(..), emptyCForest, openForest) - import Cursor.Simple.Tree.TestUtils +import Cursor.Tree (TreeCursor (..), emptyCForest, openForest) +import Test.Hspec +import Test.Validity +import Text.Show.Pretty spec :: Spec spec = do describe "treeCursorSelection" $ - it "produces valids on valids" $ producesValidsOnValids (treeCursorSelection @Bool @Bool) + it "produces valids on valids" $ + producesValid (treeCursorSelection @Bool @Bool) describe "treeCursorSelect" $ do - it "produces valids on valids" $ producesValidsOnValids2 (treeCursorSelect @Bool) + it "produces valids on valids" $ producesValid2 (treeCursorSelect @Bool) it "is identity with the current selection" $ - forAllValid $ \tc -> - let sel = treeCursorSelection tc - in case treeCursorSelect @Bool sel tc of - Nothing -> expectationFailure "treeCursorSelect should not have failed." - Just r -> - unless (r == tc) $ - expectationFailure $ - unlines - [ "selection:" - , ppShow sel - , "expected:" - , drawTreeCursor tc - , "actual:" - , drawTreeCursor r - ] + forAllValid $ + \tc -> + let sel = treeCursorSelection tc + in case treeCursorSelect @Bool sel tc of + Nothing -> expectationFailure "treeCursorSelect should not have failed." + Just r -> + unless (r == tc) $ + expectationFailure $ + unlines + [ "selection:", + ppShow sel, + "expected:", + drawTreeCursor tc, + "actual:", + drawTreeCursor r + ] describe "treeCursorSelectPrevOnSameLevel" $ do testMovementM treeCursorSelectPrevOnSameLevel it "selects the previous element" pending it "after treeCursorSelectNextOnSameLevel is identity if they don't fail" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (treeCursorSelectNextOnSameLevel @Bool) (treeCursorSelectPrevOnSameLevel @Bool) describe "treeCursorSelectNextOnSameLevel" $ do testMovementM treeCursorSelectNextOnSameLevel it "selects the next element" pending it "after treeCursorSelectPrevOnSameLevel is identity if they don't fail" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (treeCursorSelectPrevOnSameLevel @Bool) (treeCursorSelectNextOnSameLevel @Bool) + describe "treeCursorSelectFirstOnSameLevel" $ do + testMovement treeCursorSelectFirstOnSameLevel + it "selects the previous element" pending + describe "treeCursorSelectNextOnSameLevel" $ do + testMovement treeCursorSelectLastOnSameLevel + it "selects the next element" pending describe "treeCursorSelectAbovePrev" $ do testMovementM treeCursorSelectAbovePrev it "Works for this classic example" $ - -- > 0 - -- > 1 - -- > 2 - -- > 3 <- expected end cursor - -- > 4 <- start cursor - do - let start = - TreeCursor - { treeAbove = - Just - (TreeAbove - { treeAboveLefts = - [CNode 1 $ openForest [CNode 2 $ openForest [CNode 3 emptyCForest]]] - , treeAboveAbove = Nothing - , treeAboveNode = 0 - , treeAboveRights = [] - }) - , treeCurrent = 4 :: Int - , treeBelow = emptyCForest - } - expected = - TreeCursor - { treeAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 0 - , treeAboveRights = [CNode 4 emptyCForest] - }) - , treeAboveNode = 1 - , treeAboveRights = [] - }) - , treeAboveNode = 2 - , treeAboveRights = [] - }) - , treeCurrent = 3 - , treeBelow = emptyCForest - } - case treeCursorSelectAbovePrev start of - Nothing -> expectationFailure "treeCursorSelectAbovePrev should not have failed" - Just r -> r `treeShouldBe` expected + -- > 0 + -- > 1 + -- > 2 + -- > 3 <- expected end cursor + -- > 4 <- start cursor + do + let start = + TreeCursor + { treeAbove = + Just + ( TreeAbove + { treeAboveLefts = + [CNode 1 $ openForest [CNode 2 $ openForest [CNode 3 emptyCForest]]], + treeAboveAbove = Nothing, + treeAboveNode = 0, + treeAboveRights = [] + } + ), + treeCurrent = 4 :: Int, + treeBelow = emptyCForest + } + expected = + TreeCursor + { treeAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 0, + treeAboveRights = [CNode 4 emptyCForest] + } + ), + treeAboveNode = 1, + treeAboveRights = [] + } + ), + treeAboveNode = 2, + treeAboveRights = [] + } + ), + treeCurrent = 3, + treeBelow = emptyCForest + } + case treeCursorSelectAbovePrev start of + Nothing -> expectationFailure "treeCursorSelectAbovePrev should not have failed" + Just r -> r `treeShouldBe` expected it "selects the previous element" pending it "after treeCursorSelectAboveNext is identity if they don't fail" $ - forAllValid $ \tc -> - case treeCursorSelectAboveNext @Bool tc of - Nothing -> pure () - Just tc' -> - case treeCursorSelectAbovePrev tc' of - Nothing -> expectationFailure "treeCursorSelectAbovePrev should not have failed." - Just tc'' -> - unless (tc == tc'') $ - expectationFailure $ - unlines - [ "treeCursorSelectAboveNext and treeCursorSelectAbovePrev should have round-tripped." - , "Started with:" - , drawTreeCursor tc - , "after treeCursorSelectAboveNext" - , drawTreeCursor tc' - , "after treeCursorSelectAbovePrev" - , drawTreeCursor tc'' - , "instead of" - , drawTreeCursor tc - ] + forAllValid $ + \tc -> + case treeCursorSelectAboveNext @Bool tc of + Nothing -> pure () + Just tc' -> + case treeCursorSelectAbovePrev tc' of + Nothing -> expectationFailure "treeCursorSelectAbovePrev should not have failed." + Just tc'' -> + unless (tc == tc'') $ + expectationFailure $ + unlines + [ "treeCursorSelectAboveNext and treeCursorSelectAbovePrev should have round-tripped.", + "Started with:", + drawTreeCursor tc, + "after treeCursorSelectAboveNext", + drawTreeCursor tc', + "after treeCursorSelectAbovePrev", + drawTreeCursor tc'', + "instead of", + drawTreeCursor tc + ] describe "treeCursorSelectAboveNext" $ do testMovementM treeCursorSelectAboveNext it "Works for this classic example" $ - -- > 0 - -- > 1 - -- > 2 - -- > 3 <- start cursor - -- > 4 <- expected end cursor - do - let start = - TreeCursor - { treeAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = - Just - (TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 0 - , treeAboveRights = [node 4 []] - }) - , treeAboveNode = 1 - , treeAboveRights = [] - }) - , treeAboveNode = 2 - , treeAboveRights = [] - }) - , treeCurrent = 3 - , treeBelow = emptyCForest - } - expected = - TreeCursor - { treeAbove = - Just - (TreeAbove - { treeAboveLefts = - [CNode 1 $ openForest [CNode 2 $ openForest [CNode 3 emptyCForest]]] - , treeAboveAbove = Nothing - , treeAboveNode = 0 - , treeAboveRights = [] - }) - , treeCurrent = 4 :: Int - , treeBelow = emptyCForest - } - case treeCursorSelectAboveNext start of - Nothing -> expectationFailure "treeCursorSelectAboveNext should not have failed." - Just r -> r `treeShouldBe` expected + -- > 0 + -- > 1 + -- > 2 + -- > 3 <- start cursor + -- > 4 <- expected end cursor + do + let start = + TreeCursor + { treeAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = + Just + ( TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 0, + treeAboveRights = [node 4 []] + } + ), + treeAboveNode = 1, + treeAboveRights = [] + } + ), + treeAboveNode = 2, + treeAboveRights = [] + } + ), + treeCurrent = 3, + treeBelow = emptyCForest + } + expected = + TreeCursor + { treeAbove = + Just + ( TreeAbove + { treeAboveLefts = + [CNode 1 $ openForest [CNode 2 $ openForest [CNode 3 emptyCForest]]], + treeAboveAbove = Nothing, + treeAboveNode = 0, + treeAboveRights = [] + } + ), + treeCurrent = 4 :: Int, + treeBelow = emptyCForest + } + case treeCursorSelectAboveNext start of + Nothing -> expectationFailure "treeCursorSelectAboveNext should not have failed." + Just r -> r `treeShouldBe` expected it "selects the next element" pending it "after treeCursorSelectAbovePrev is identity if they don't fail" $ - forAllValid $ \tc -> - case treeCursorSelectAbovePrev @Bool tc of - Nothing -> pure () - Just tc' -> - case treeCursorSelectAboveNext tc' of - Nothing -> pure () - Just tc'' -> - unless (tc == tc'') $ - expectationFailure $ - unlines - [ "treeCursorSelectAbovePrev and treeCursorSelectAboveNext should have round-tripped." - , "Started with:" - , drawTreeCursor tc - , "after treeCursorSelectAbovePrev" - , drawTreeCursor tc' - , "after treeCursorSelectAboveNext" - , drawTreeCursor tc'' - , "instead of" - , drawTreeCursor tc - ] + forAllValid $ + \tc -> + case treeCursorSelectAbovePrev @Bool tc of + Nothing -> pure () + Just tc' -> + case treeCursorSelectAboveNext tc' of + Nothing -> pure () + Just tc'' -> + unless (tc == tc'') $ + expectationFailure $ + unlines + [ "treeCursorSelectAbovePrev and treeCursorSelectAboveNext should have round-tripped.", + "Started with:", + drawTreeCursor tc, + "after treeCursorSelectAbovePrev", + drawTreeCursor tc', + "after treeCursorSelectAboveNext", + drawTreeCursor tc'', + "instead of", + drawTreeCursor tc + ] describe "treeCursorSelectPrev" $ do testMovementM treeCursorSelectPrev it "selects the previous element" pending it "after treeCursorSelectNext is identity if they don't fail" $ - inverseFunctionsIfSucceedOnValid (treeCursorSelectNext @Bool) (treeCursorSelectPrev @Bool) + inverseFunctionsIfSucceed (treeCursorSelectNext @Bool) (treeCursorSelectPrev @Bool) describe "treeCursorSelectNext" $ do testMovementM treeCursorSelectNext it "selects the next element" pending it "after treeCursorSelectPrev is identity if they don't fail" $ - inverseFunctionsIfSucceedOnValid (treeCursorSelectPrev @Bool) (treeCursorSelectNext @Bool) + inverseFunctionsIfSucceed (treeCursorSelectPrev @Bool) (treeCursorSelectNext @Bool) describe "treeCursorSelectFirst" $ do testMovement treeCursorSelectFirst it "selects the first element" pending - it "is idempotent" $ idempotentOnValid $ treeCursorSelectFirst @Bool + it "is idempotent" $ idempotent $ treeCursorSelectFirst @Bool describe "treeCursorSelectLast" $ do testMovement treeCursorSelectLast it "selects the last element" pending - it "is idempotent" $ idempotentOnValid $ treeCursorSelectLast @Bool + it "is idempotent" $ idempotent $ treeCursorSelectLast @Bool describe "treeCursorSelectAbove" $ do testMovementM treeCursorSelectAbove it "selects the element above" pending it "after treeCursorSelectBelow is identity if they don't fail" $ - inverseFunctionsIfSucceedOnValid (treeCursorSelectBelowAtStart @Bool) $ - treeCursorSelectAbove @Bool + inverseFunctionsIfSucceed (treeCursorSelectBelowAtStart @Bool) $ + treeCursorSelectAbove @Bool describe "treeCursorSelectBelowAtPos" $ do - it "produces valids on valids" $ producesValidsOnValids2 $ treeCursorSelectBelowAtPos @Bool + it "produces valids on valids" $ producesValid2 $ treeCursorSelectBelowAtPos @Bool it "is a movement" $ forAllValid $ \n -> isMovementM $ treeCursorSelectBelowAtPos n it "selects the element n-th below" pending describe "treeCursorSelectBelowAtStart" $ do diff --git a/test/Cursor/Simple/Tree/PromoteSpec.hs b/test/Cursor/Simple/Tree/PromoteSpec.hs --- a/test/Cursor/Simple/Tree/PromoteSpec.hs +++ b/test/Cursor/Simple/Tree/PromoteSpec.hs @@ -1,30 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.PromoteSpec - ( spec - ) where - -import Data.Tree - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () +import Cursor.Simple.Tree.TestUtils import Cursor.Tree - ( CTree(..) - , TreeAbove(..) - , TreeCursor(..) - , closedForest - , emptyCForest - , openForest + ( TreeCursor (..), + closedForest, + emptyCForest, + openForest, ) - -import Cursor.Simple.Tree.TestUtils +import Data.Tree +import Test.Hspec +import Test.Validity spec :: Spec spec = do @@ -32,27 +27,27 @@ applicativeSpec @PromoteElemResult monadSpec @PromoteElemResult describe "treeCursorPromoteElem" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorPromoteElem @Bool + it "produces valids on valids" $ producesValid $ treeCursorPromoteElem @Bool it "Works on the example from the docs" $ let promoteStart = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'b' [node 'c' []]] - , treeAboveAbove = + { treeAboveLefts = [node 'b' [node 'c' []]], + treeAboveAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'h' []] - } - , treeAboveNode = 'a' - , treeAboveRights = [node 'f' [node 'g' []]] - } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'h' []] + }, + treeAboveNode = 'a', + treeAboveRights = [node 'f' [node 'g' []]] + }, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] } promoteEnd = TreeCursor @@ -61,18 +56,18 @@ TreeAbove { treeAboveLefts = [ CNode 'a' $ - openForest - [ CNode 'b' $ - openForest [CNode 'c' emptyCForest, CNode 'e' emptyCForest] - , CNode 'f' $ closedForest [Node 'g' []] - ] - ] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [CNode 'h' emptyCForest] - } - , treeCurrent = 'd' - , treeBelow = emptyCForest + openForest + [ CNode 'b' $ + openForest [CNode 'c' emptyCForest, CNode 'e' emptyCForest], + CNode 'f' $ closedForest [Node 'g' []] + ] + ], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [CNode 'h' emptyCForest] + }, + treeCurrent = 'd', + treeBelow = emptyCForest } in case treeCursorPromoteElem promoteStart of PromotedElem tc' -> tc' `treeShouldBe` promoteEnd @@ -82,27 +77,27 @@ applicativeSpec @PromoteResult monadSpec @PromoteResult describe "treeCursorPromoteSubTree" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorPromoteSubTree @Bool + it "produces valids on valids" $ producesValid $ treeCursorPromoteSubTree @Bool it "Works on the example from the docs" $ let promoteStart = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]] - , treeAboveAbove = + { treeAboveLefts = [CNode 'b' $ closedForest [Node 'c' []]], + treeAboveAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'h' []] - } - , treeAboveNode = 'a' - , treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] - } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'h' []] + }, + treeAboveNode = 'a', + treeAboveRights = [CNode 'f' $ closedForest [Node 'g' []]] + }, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] } promoteEnd = TreeCursor @@ -111,17 +106,17 @@ TreeAbove { treeAboveLefts = [ CNode 'a' $ - openForest - [ CNode 'b' $ closedForest [Node 'c' []] - , CNode 'f' $ closedForest [Node 'g' []] - ] - ] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [CNode 'h' $ closedForest []] - } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] + openForest + [ CNode 'b' $ closedForest [Node 'c' []], + CNode 'f' $ closedForest [Node 'g' []] + ] + ], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [CNode 'h' $ closedForest []] + }, + treeCurrent = 'd', + treeBelow = closedForest [Node 'e' []] } in case treeCursorPromoteSubTree promoteStart of Promoted tc' -> tc' `treeShouldBe` promoteEnd diff --git a/test/Cursor/Simple/Tree/SwapSpec.hs b/test/Cursor/Simple/Tree/SwapSpec.hs --- a/test/Cursor/Simple/Tree/SwapSpec.hs +++ b/test/Cursor/Simple/Tree/SwapSpec.hs @@ -1,96 +1,94 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cursor.Simple.Tree.SwapSpec - ( spec - ) where - -import Test.Hspec - -import Test.Validity + ( spec, + ) +where import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree (TreeAbove(..), TreeCursor(..), emptyCForest) - import Cursor.Simple.Tree.TestUtils +import Cursor.Tree (TreeCursor (..), emptyCForest) +import Test.Hspec +import Test.Validity spec :: Spec spec = do functorSpec @SwapResult describe "treeCursorSwapPrev" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorSwapPrev @Bool @Bool + it "produces valids on valids" $ producesValid $ treeCursorSwapPrev @Bool @Bool it "works on the example from the docs" $ let start = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'a' []] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [] - } - , treeCurrent = 'b' - , treeBelow = emptyCForest + { treeAboveLefts = [node 'a' []], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [] + }, + treeCurrent = 'b', + treeBelow = emptyCForest } end = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'a' []] - } - , treeCurrent = 'b' - , treeBelow = emptyCForest + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'a' []] + }, + treeCurrent = 'b', + treeBelow = emptyCForest } in case treeCursorSwapPrev start of Swapped r -> r `treeShouldBe` end _ -> expectationFailure "treeCursorSwapPrev should not have failed." it "reverts treeCursorSwapNext" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (treeCursorSwapNext @Bool @Bool) (treeCursorSwapPrev @Bool @Bool) it "swaps the current node with the previous node" pending describe "treeCursorSwapNext" $ do - it "produces valids on valids" $ producesValidsOnValids $ treeCursorSwapNext @Bool @Bool + it "produces valids on valids" $ producesValid $ treeCursorSwapNext @Bool @Bool it "works on the example from the docs" $ let start = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [node 'b' []] - } - , treeCurrent = 'a' - , treeBelow = emptyCForest + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [node 'b' []] + }, + treeCurrent = 'a', + treeBelow = emptyCForest } end = TreeCursor { treeAbove = Just TreeAbove - { treeAboveLefts = [node 'b' []] - , treeAboveAbove = Nothing - , treeAboveNode = 'p' - , treeAboveRights = [] - } - , treeCurrent = 'a' - , treeBelow = emptyCForest + { treeAboveLefts = [node 'b' []], + treeAboveAbove = Nothing, + treeAboveNode = 'p', + treeAboveRights = [] + }, + treeCurrent = 'a', + treeBelow = emptyCForest } in case treeCursorSwapNext start of Swapped r -> r `treeShouldBe` end _ -> expectationFailure "treeCursorSwapNext should not have failed." it "reverts treeCursorSwapNext" $ - inverseFunctionsIfSucceedOnValid + inverseFunctionsIfSucceed (treeCursorSwapPrev @Bool @Bool) (treeCursorSwapNext @Bool @Bool) it "swaps the current node with the next node" pending diff --git a/test/Cursor/Simple/Tree/TestUtils.hs b/test/Cursor/Simple/Tree/TestUtils.hs --- a/test/Cursor/Simple/Tree/TestUtils.hs +++ b/test/Cursor/Simple/Tree/TestUtils.hs @@ -1,33 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Simple.Tree.TestUtils where -import Data.Tree - import Control.Monad (unless) - -import Test.Hspec - -import Test.QuickCheck -import Test.Validity - import Cursor.Simple.Tree hiding (TreeCursor) import qualified Cursor.Simple.Tree as STC (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree (CTree(..), closedForest) +import Cursor.Tree (closedForest) +import Data.Tree +import Test.Hspec +import Test.QuickCheck +import Test.Validity testMovement :: (forall a. STC.TreeCursor a -> STC.TreeCursor a) -> Spec testMovement func = do - it "produces valids on valids" $ producesValidsOnValids $ func @Bool + it "produces valids on valids" $ producesValid $ func @Bool it "is a movement" $ isMovement func testMovementM :: (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Spec testMovementM func = do - it "produces valids on valids" $ producesValidsOnValids $ func @Bool + it "produces valids on valids" $ producesValid $ func @Bool it "is a movement" $ isMovementM func isMovementM :: (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Property @@ -39,13 +35,13 @@ let ne = rebuildCTree $ rebuildTreeCursor lec ne' = rebuildCTree $ rebuildTreeCursor lec' in unless (ne == ne') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ drawTreeCursor lec - , "Tree before: \n" ++ drawTree (fmap show ne) - , "Cursor after: \n" ++ drawTreeCursor lec' - , "Tree after: \n" ++ drawTree (fmap show ne') - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ drawTreeCursor lec, + "Tree before: \n" ++ drawTree (fmap show ne), + "Cursor after: \n" ++ drawTreeCursor lec', + "Tree after: \n" ++ drawTree (fmap show ne') + ] isMovement :: (forall a. STC.TreeCursor a -> STC.TreeCursor a) -> Property isMovement func = @@ -55,14 +51,14 @@ treeShouldBe :: (Show a, Eq a) => STC.TreeCursor a -> STC.TreeCursor a -> Expectation treeShouldBe actual expected = unless (actual == expected) $ - expectationFailure $ - unlines - [ "The following should have been equal." - , "actual:" - , drawTreeCursor actual - , "expected:" - , drawTreeCursor expected - ] + expectationFailure $ + unlines + [ "The following should have been equal.", + "actual:", + drawTreeCursor actual, + "expected:", + drawTreeCursor expected + ] instance CanFail SwapResult where hasFailed (Swapped _) = False diff --git a/test/Cursor/TextFieldSpec.hs b/test/Cursor/TextFieldSpec.hs --- a/test/Cursor/TextFieldSpec.hs +++ b/test/Cursor/TextFieldSpec.hs @@ -4,161 +4,185 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.TextFieldSpec - ( spec - ) where - -import Test.Hspec - -import Test.QuickCheck -import Test.Validity - --- import Test.Validity.Optics -import Text.Show.Pretty (ppShow) - -import qualified Data.Text as T - -import qualified Data.List.NonEmpty as NE + ( spec, + ) +where import Control.Monad - import Cursor.List.NonEmpty import Cursor.TextField import Cursor.TextField.Gen () import Cursor.Types +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Text.Show.Pretty (ppShow) spec :: Spec spec = do - eqSpecOnValid @TextFieldCursor + eqSpec @TextFieldCursor genValidSpec @TextFieldCursor describe "Validity TextFieldCursor" $ do it "consider a textfield with a newline in the previous lines invalid" $ - forAllValid $ \tc -> - shouldBeInvalid $ - TextFieldCursor - { textFieldCursorNonEmpty = - NonEmptyCursor - {nonEmptyCursorPrev = ["\n"], nonEmptyCursorCurrent = tc, nonEmptyCursorNext = []} - } + forAllValid $ + \tc -> + shouldBeInvalid $ + TextFieldCursor + { textFieldCursorNonEmpty = + NonEmptyCursor + { nonEmptyCursorPrev = ["\n"], + nonEmptyCursorCurrent = tc, + nonEmptyCursorNext = [] + } + } it "consider a textfield with a newline in the next lines invalid" $ - forAllValid $ \tc -> - shouldBeInvalid $ - TextFieldCursor - { textFieldCursorNonEmpty = - NonEmptyCursor - {nonEmptyCursorPrev = [], nonEmptyCursorCurrent = tc, nonEmptyCursorNext = ["\n"]} - } + forAllValid $ + \tc -> + shouldBeInvalid $ + TextFieldCursor + { textFieldCursorNonEmpty = + NonEmptyCursor + { nonEmptyCursorPrev = [], + nonEmptyCursorCurrent = tc, + nonEmptyCursorNext = ["\n"] + } + } describe "makeTextFieldCursor" $ do it "produces a valid cursor for \"\\n\"" $ shouldBeValid $ makeTextFieldCursor "\n" it "produces a valid cursor for \"\\n\\n\"" $ shouldBeValid $ makeTextFieldCursor "\n\n" - it "produces valid cursors" $ producesValidsOnValids makeTextFieldCursor + it "produces valid cursors" $ producesValid makeTextFieldCursor describe "makeTextFieldCursorWithSelection" $ do it "produces a valid cursor for \"\\n\"" $ - forAllValid $ \x -> - forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n" + forAllValid $ + \x -> + forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n" it "produces a valid cursor for \"\\n\\n\"" $ - forAllValid $ \x -> - forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n\n" - it "produces valid cursors" $ producesValidsOnValids3 makeTextFieldCursorWithSelection + forAllValid $ + \x -> + forAllValid $ \y -> shouldBeValid $ makeTextFieldCursorWithSelection x y "\n\n" + it "produces valid cursors" $ producesValid3 makeTextFieldCursorWithSelection it "is the inverse of rebuildTextFieldCursor when using the current selection" $ - forAllValid $ \tfc -> do - let (x, y) = textFieldCursorSelection tfc - t = rebuildTextFieldCursor tfc - case makeTextFieldCursorWithSelection x y t of - Nothing -> expectationFailure "makeTextFieldCursorWithSelection should not have failed." - Just tfc' -> - unless (tfc' == tfc) $ - expectationFailure $ - unlines - [ "expected" - , ppShow tfc - , "actual" - , ppShow tfc' - , "The selection of the original (expected) cursor was:" - , show (x, y) - , "The rebuild text was:" - , show t - ] + forAllValid $ + \tfc -> do + let (x, y) = textFieldCursorSelection tfc + t = rebuildTextFieldCursor tfc + case makeTextFieldCursorWithSelection x y t of + Nothing -> expectationFailure "makeTextFieldCursorWithSelection should not have failed." + Just tfc' -> + unless (tfc' == tfc) $ + expectationFailure $ + unlines + [ "expected", + ppShow tfc, + "actual", + ppShow tfc', + "The selection of the original (expected) cursor was:", + show (x, y), + "The rebuild text was:", + show t + ] describe "rebuildTextFieldCursorLines" $ do - it "produces valid lists" $ producesValidsOnValids rebuildTextFieldCursorLines + it "produces valid lists" $ producesValid rebuildTextFieldCursorLines it "produces texts without newlines" $ - forAllValid $ \tfc -> do - let ls = NE.toList $ rebuildTextFieldCursorLines tfc - unless (all (T.all (/= '\n')) ls) $ - expectationFailure $ - unlines $ "Some of the following lines contain a newline:" : map show ls + forAllValid $ + \tfc -> do + let ls = NE.toList $ rebuildTextFieldCursorLines tfc + unless (all (T.all (/= '\n')) ls) $ + expectationFailure $ + unlines $ + "Some of the following lines contain a newline:" : map show ls describe "rebuildTextFieldCursor" $ do - it "produces valid texts" $ producesValidsOnValids rebuildTextFieldCursor + it "produces valid texts" $ producesValid rebuildTextFieldCursor it "is the inverse of makeTextFieldCursor" $ - inverseFunctionsOnValid makeTextFieldCursor rebuildTextFieldCursor + inverseFunctions makeTextFieldCursor rebuildTextFieldCursor it "is the inverse of makeTextFieldCursorWithSelection for integers, for any index" $ - forAllValid $ \x -> - forAllValid $ \y -> - inverseFunctionsIfFirstSucceedsOnValid - (makeTextFieldCursorWithSelection x y) - rebuildTextFieldCursor + forAllValid $ + \x -> + forAllValid $ \y -> + inverseFunctionsIfFirstSucceeds + (makeTextFieldCursorWithSelection x y) + rebuildTextFieldCursor describe "textFieldCursorSelection" $ - it "produces valid tuples" $ producesValidsOnValids textFieldCursorSelection + it "produces valid tuples" $ + producesValid textFieldCursorSelection describe "emptyTextFieldCursor" $ it "is valid" $ shouldBeValid emptyTextFieldCursor - describe "nullTextFieldCursor" $ it "produces valid" $ producesValidsOnValids nullTextFieldCursor + describe "nullTextFieldCursor" $ it "produces valid" $ producesValid nullTextFieldCursor describe "textFieldCursorSelectPrevLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectPrevLine + it "produces valid cursors" $ producesValid textFieldCursorSelectPrevLine it "is a movement" $ isMovementM textFieldCursorSelectPrevLine it "selects the previous line" pending describe "textFieldCursorSelectNextLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectNextLine + it "produces valid cursors" $ producesValid textFieldCursorSelectNextLine it "is a movement" $ isMovementM textFieldCursorSelectNextLine it "selects the next line" pending describe "textFieldCursorSelectFirstLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectFirstLine + it "produces valid cursors" $ producesValid textFieldCursorSelectFirstLine it "is a movement" $ isMovement textFieldCursorSelectFirstLine - it "is idempotent" $ idempotentOnValid textFieldCursorSelectFirstLine + it "is idempotent" $ idempotent textFieldCursorSelectFirstLine it "selects the first line" pending describe "textFieldCursorSelectLastLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectLastLine + it "produces valid cursors" $ producesValid textFieldCursorSelectLastLine it "is a movement" $ isMovement textFieldCursorSelectLastLine - it "is idempotent" $ idempotentOnValid textFieldCursorSelectLastLine + it "is idempotent" $ idempotent textFieldCursorSelectLastLine it "selects the last line" pending describe "textFieldCursorSelectPrevChar" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectPrevChar + it "produces valid cursors" $ producesValid textFieldCursorSelectPrevChar it "selects the previous character on the current line" pending describe "textFieldCursorSelectNextChar" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectNextChar + it "produces valid cursors" $ producesValid textFieldCursorSelectNextChar it "selects the previous character on the current line" pending + describe "textFieldCursorSelectBeginWord" $ + it "produces valid cursors" $ + producesValid textFieldCursorSelectBeginWord + describe "textFieldCursorSelectEndWord" $ + it "produces valid cursors" $ + producesValid textFieldCursorSelectEndWord + describe "textFieldCursorSelectPrevWord" $ + it "produces valid cursors" $ + producesValid textFieldCursorSelectPrevWord + describe "textFieldCursorSelectNextWord" $ + it "produces valid cursors" $ + producesValid textFieldCursorSelectNextWord describe "textFieldCursorIndexOnLine" $ do - it "produces valid indices" $ producesValidsOnValids textFieldCursorIndexOnLine + it "produces valid indices" $ producesValid textFieldCursorIndexOnLine it "returns the index on the current line" pending describe "textFieldCursorSelectIndexOnLine" $ do it "produces valid cursors for any index" $ - producesValidsOnValids2 textFieldCursorSelectIndexOnLine + producesValid2 textFieldCursorSelectIndexOnLine it "selects the given index on the current line" pending describe "textFieldCursorInsertChar" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (textFieldCursorInsertChar d) + forAllValid $ + \d -> producesValid (textFieldCursorInsertChar d) it "inserts a character before the cursor on the current line" pending describe "textFieldCursorAppendChar" $ do it "produces valid cursors" $ - forAllValid $ \d -> producesValidsOnValids (textFieldCursorAppendChar d) + forAllValid $ + \d -> producesValid (textFieldCursorAppendChar d) it "inserts a character after the cursor on the currrent line" pending describe "textFieldCursorInsertNewline" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorInsertNewline + it "produces valid cursors" $ producesValid textFieldCursorInsertNewline it "inserts a new line" pending describe "textFieldCursorAppendNewline" $ - it "produces valid cursors" $ producesValidsOnValids textFieldCursorAppendNewline + it "produces valid cursors" $ + producesValid textFieldCursorAppendNewline describe "textFieldCursorRemove" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorRemove + it "produces valid cursors" $ producesValid textFieldCursorRemove it "removes empty text field cursor" $ textFieldCursorRemove emptyTextFieldCursor `shouldBe` Just Deleted it "removes a character or a line" pending describe "textFieldCursorDelete" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorDelete + it "produces valid cursors" $ producesValid textFieldCursorDelete it "removes empty text field cursor" $ textFieldCursorDelete emptyTextFieldCursor `shouldBe` Just Deleted it "deletes a character or a line" pending describe "textFieldCursorSelectStartOfLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectStartOfLine + it "produces valid cursors" $ producesValid textFieldCursorSelectStartOfLine it "selects the start of the current line" pending describe "textFieldCursorSelectEndOfLine" $ do - it "produces valid cursors" $ producesValidsOnValids textFieldCursorSelectEndOfLine + it "produces valid cursors" $ producesValid textFieldCursorSelectEndOfLine it "selects the end of the current line" pending isMovementM :: (TextFieldCursor -> Maybe TextFieldCursor) -> Property @@ -170,13 +194,13 @@ let tf = rebuildTextFieldCursor tfc tf' = rebuildTextFieldCursor tfc' in unless (tf == tf') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show tfc - , "TextField before: \n" ++ show tf - , "Cursor after: \n" ++ show tfc' - , "TextField after: \n" ++ show tf' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show tfc, + "TextField before: \n" ++ show tf, + "Cursor after: \n" ++ show tfc', + "TextField after: \n" ++ show tf' + ] isMovement :: (TextFieldCursor -> TextFieldCursor) -> Property isMovement func = diff --git a/test/Cursor/TextSpec.hs b/test/Cursor/TextSpec.hs --- a/test/Cursor/TextSpec.hs +++ b/test/Cursor/TextSpec.hs @@ -1,20 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Cursor.TextSpec - ( spec - ) where - -import Test.Hspec -import Test.QuickCheck -import Test.Validity + ( spec, + ) +where import Control.Monad - import Cursor.List import Cursor.Text -import Cursor.Text.Gen () +import Cursor.Text.Gen +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import Test.Hspec +import Test.QuickCheck +import Test.Validity spec :: Spec spec = do @@ -23,88 +25,165 @@ describe "Validity TextCursor" $ do it "considers a text cursor with a newline in the previous characters invalid" $ shouldBeInvalid $ - TextCursor {textCursorList = ListCursor {listCursorPrev = "\n", listCursorNext = ""}} + TextCursor {textCursorList = ListCursor {listCursorPrev = "\n", listCursorNext = ""}} it "considers a text cursor with a newline in the next characters invalid" $ shouldBeInvalid $ - TextCursor {textCursorList = ListCursor {listCursorPrev = "", listCursorNext = "\n"}} + TextCursor {textCursorList = ListCursor {listCursorPrev = "", listCursorNext = "\n"}} it "considers a text cursor with an unsafe character in the previous characters invalid" $ shouldBeInvalid $ - TextCursor {textCursorList = ListCursor {listCursorPrev = "\55810", listCursorNext = ""}} + TextCursor {textCursorList = ListCursor {listCursorPrev = "\55810", listCursorNext = ""}} it "considers a text cursor with an unsafe character in the next characters invalid" $ shouldBeInvalid $ - TextCursor {textCursorList = ListCursor {listCursorPrev = "\55810", listCursorNext = "\n"}} + TextCursor {textCursorList = ListCursor {listCursorPrev = "\55810", listCursorNext = "\n"}} describe "emptyTextCursor" $ it "is valid" $ shouldBeValid emptyTextCursor describe "makeTextCursor" $ - it "produces valid list cursors" $ producesValidsOnValids makeTextCursor + it "produces valid list cursors" $ + producesValid makeTextCursor describe "makeTextCursorWithSelection" $ - it "produces valid list cursors" $ producesValidsOnValids2 makeTextCursorWithSelection + it "produces valid list cursors" $ + producesValid2 makeTextCursorWithSelection describe "rebuildTextCursor" $ do - it "produces valid lists" $ producesValidsOnValids rebuildTextCursor + it "produces valid lists" $ producesValid rebuildTextCursor it "is the inverse of makeTextCursor" $ - inverseFunctionsIfFirstSucceedsOnValid makeTextCursor rebuildTextCursor + inverseFunctionsIfFirstSucceeds makeTextCursor rebuildTextCursor it "is the inverse of makeTextCursorWithSelection for any index" $ - forAllUnchecked $ \i -> - inverseFunctionsIfFirstSucceedsOnValid (makeTextCursorWithSelection i) rebuildTextCursor - describe "textCursorNull" $ it "produces valid bools" $ producesValidsOnValids textCursorNull - describe "textCursorLength" $ it "produces valid ints" $ producesValidsOnValids textCursorLength - describe "textCursorIndex" $ it "produces valid indices" $ producesValidsOnValids textCursorIndex + forAllValid $ + \i -> + inverseFunctionsIfFirstSucceeds (makeTextCursorWithSelection i) rebuildTextCursor + describe "textCursorNull" $ it "produces valid bools" $ producesValid textCursorNull + describe "textCursorLength" $ it "produces valid ints" $ producesValid textCursorLength + describe "textCursorIndex" $ it "produces valid indices" $ producesValid textCursorIndex describe "textCursorSelectPrev" $ do - it "produces valid cursors" $ producesValidsOnValids textCursorSelectPrev + it "produces valid cursors" $ producesValid textCursorSelectPrev it "is a movement" $ isMovementM textCursorSelectPrev it "selects the previous position" pending describe "textCursorSelectNext" $ do - it "produces valid cursors" $ producesValidsOnValids textCursorSelectNext + it "produces valid cursors" $ producesValid textCursorSelectNext it "is a movement" $ isMovementM textCursorSelectNext it "selects the next position" pending describe "textCursorSelectIndex" $ do - it "produces valid cursors" $ producesValidsOnValids2 textCursorSelectIndex - it "is a movement" $ forAllUnchecked $ \ix -> isMovement (textCursorSelectIndex ix) + it "produces valid cursors" $ producesValid2 textCursorSelectIndex + it "is a movement" $ forAllValid $ \ix -> isMovement (textCursorSelectIndex ix) it "selects the position at the given index" pending it "produces a cursor that has the given selection for valid selections in the cursor" $ - forAllValid $ \tc -> - forAll (choose (0, textCursorLength tc)) $ \i -> - textCursorIndex (textCursorSelectIndex i tc) `shouldBe` i + forAllValid $ + \tc -> + forAll (choose (0, textCursorLength tc)) $ \i -> + textCursorIndex (textCursorSelectIndex i tc) `shouldBe` i describe "textCursorSelectStart" $ do - it "produces valid cursors" $ producesValidsOnValids textCursorSelectStart + it "produces valid cursors" $ producesValid textCursorSelectStart it "is a movement" $ isMovement textCursorSelectStart it "is idempotent" $ idempotent textCursorSelectStart it "selects the starting position" pending describe "textCursorSelectEnd" $ do - it "produces valid cursors" $ producesValidsOnValids textCursorSelectEnd + it "produces valid cursors" $ producesValid textCursorSelectEnd it "is a movement" $ isMovement textCursorSelectEnd it "is idempotent" $ idempotent textCursorSelectEnd it "selects the end position" pending describe "textCursorPrevChar" $ do - it "produces valid items" $ producesValidsOnValids textCursorPrevChar + it "produces valid items" $ producesValid textCursorPrevChar it "returns the item before the position" pending describe "textCursorNextChar" $ do - it "produces valid items" $ producesValidsOnValids textCursorNextChar + it "produces valid items" $ producesValid textCursorNextChar it "returns the item after the position" pending + describe "textCursorSelectBeginWord" $ do + it "produces valid items" $ producesValid textCursorSelectBeginWord + it "is a movement" $ isMovement textCursorSelectBeginWord + it "is idempotent" $ isIdempotentForSentence textCursorSelectBeginWord + it "works for this example" $ + textCursorSelectBeginWord (buildTestTextCursor "hell" "o") `shouldBe` buildTestTextCursor "" "hello" + it "works for this example" $ + textCursorSelectBeginWord (buildTestTextCursor "hello " " world") `shouldBe` buildTestTextCursor "" "hello world" + it "works for this example" $ + textCursorSelectBeginWord (buildTestTextCursor "hello " "world") `shouldBe` buildTestTextCursor "hello " "world" + it "works for this example" $ + textCursorSelectBeginWord (buildTestTextCursor "" " hello") `shouldBe` buildTestTextCursor "" " hello" + describe "textCursorSelectEndWord" $ do + it "produces valid items" $ producesValid textCursorSelectEndWord + it "is a movement" $ isMovement textCursorSelectEndWord + it "is idempotent" $ isIdempotentForSentence textCursorSelectEndWord + it "works for this example" $ + textCursorSelectEndWord (buildTestTextCursor "hell" "o") `shouldBe` buildTestTextCursor "hello" "" + it "works for this example" $ + textCursorSelectEndWord (buildTestTextCursor "hello " " world") `shouldBe` buildTestTextCursor "hello world" "" + it "works for this example" $ + textCursorSelectEndWord (buildTestTextCursor "hello" " world") `shouldBe` buildTestTextCursor "hello" " world" + it "works for this example" $ + textCursorSelectEndWord (buildTestTextCursor "hello " "") `shouldBe` buildTestTextCursor "hello " "" + describe "textCursorSelectNextWord" $ do + it "produces valid items" $ producesValid textCursorSelectNextWord + it "is a movement" $ isMovement textCursorSelectNextWord + it "works for this example" $ + textCursorSelectNextWord (buildTestTextCursor "" "hello") `shouldBe` buildTestTextCursor "hello" "" + it "works for this example" $ + textCursorSelectNextWord (buildTestTextCursor "hell" "o world") `shouldBe` buildTestTextCursor "hello " "world" + it "works for this example" $ + textCursorSelectNextWord (buildTestTextCursor "hello" " world") `shouldBe` buildTestTextCursor "hello " "world" + it "works for this example" $ + textCursorSelectNextWord (buildTestTextCursor "hello " "") `shouldBe` buildTestTextCursor "hello " "" + it "goes to the end of the cursor" $ + textCursorSelectNextWord (buildTestTextCursor "a\v" "b") `shouldBe` buildTestTextCursor "a\vb" "" + it "chooses the next word correctly" $ + textCursorSelectNextWord (buildTestTextCursor "a" " b c") `shouldBe` buildTestTextCursor "a " "b c" + describe "textCursorSelectPrevWord" $ do + it "produces valid items" $ producesValid textCursorSelectPrevWord + it "is a movement" $ isMovement textCursorSelectPrevWord + it "works for this example" $ + textCursorSelectPrevWord (buildTestTextCursor "hello" "") `shouldBe` buildTestTextCursor "" "hello" + it "works for this example" $ + textCursorSelectPrevWord (buildTestTextCursor "hello w" "orld") `shouldBe` buildTestTextCursor "hello" " world" + it "works for this example" $ + textCursorSelectPrevWord (buildTestTextCursor "hello " "world") `shouldBe` buildTestTextCursor "hello" " world" + it "works for this example" $ + textCursorSelectPrevWord (buildTestTextCursor " h" "ello") `shouldBe` buildTestTextCursor "" " hello" + it "goes to the beginning of the cursor" $ + textCursorSelectPrevWord (buildTestTextCursor "a" "\vb") `shouldBe` buildTestTextCursor "" "a\vb" + it "chooses the previous word correctly" $ + textCursorSelectPrevWord (buildTestTextCursor "a b" " c") `shouldBe` buildTestTextCursor "a" " b c" describe "textCursorInsert" $ do - it "produces valids" $ forAllValid $ \d -> producesValidsOnValids (textCursorInsert d) + it "produces valids" $ forAllValid $ \d -> producesValid (textCursorInsert d) it "inserts an item before the cursor" pending describe "textCursorAppend" $ do - it "produces valids" $ forAllValid $ \d -> producesValidsOnValids (textCursorAppend d) + it "produces valids" $ forAllValid $ \d -> producesValid (textCursorAppend d) it "inserts an item after the cursor" pending + describe "textCursorInsertString" $ do + it "produces valids" $ forAllValid $ \d -> producesValid (textCursorInsertString d) + it "works for this example" $ + (makeTextCursor "hello" >>= textCursorInsertString " world") + `shouldBe` makeTextCursor "hello world" + describe "textCursorAppendString" $ + it "produces valids" $ + forAllValid $ + \d -> producesValid (textCursorAppendString d) + describe "textCursorInsertText" $ + it "produces valids" $ + forAllValid $ + \d -> producesValid (textCursorInsertText d) + describe "textCursorAppendText" $ + it "produces valids" $ + forAllValid $ + \d -> producesValid (textCursorAppendText d) describe "textCursorRemove" $ do - it "produces valids" $ validIfSucceedsOnValid textCursorRemove + it "produces valids" $ validIfSucceeds textCursorRemove it "removes an item before the cursor" pending describe "textCursorDelete" $ do - it "produces valids" $ validIfSucceedsOnValid textCursorDelete + it "produces valids" $ validIfSucceeds textCursorDelete it "removes an item before the cursor" pending describe "textCursorSplit" $ do - it "produces valids" $ producesValidsOnValids textCursorSplit + it "produces valids" $ producesValid textCursorSplit it "produces two list cursors that rebuild to the rebuilding of the original" $ - forAllValid $ \lc -> - let (lc1, lc2) = textCursorSplit lc - in (rebuildTextCursor lc1 <> rebuildTextCursor lc2) `shouldBe` rebuildTextCursor lc + forAllValid $ + \lc -> + let (lc1, lc2) = textCursorSplit lc + in (rebuildTextCursor lc1 <> rebuildTextCursor lc2) `shouldBe` rebuildTextCursor lc describe "textCursorCombine" $ do - it "produces valids" $ producesValidsOnValids2 textCursorCombine + it "produces valids" $ producesValid2 textCursorCombine it "produces a list that rebuilds to the rebuilding of the original two cursors" $ - forAllValid $ \lc1 -> - forAllValid $ \lc2 -> - let lc = textCursorCombine lc1 lc2 - in rebuildTextCursor lc `shouldBe` (rebuildTextCursor lc1 <> rebuildTextCursor lc2) + forAllValid $ + \lc1 -> + forAllValid $ \lc2 -> + let lc = textCursorCombine lc1 lc2 + in rebuildTextCursor lc `shouldBe` (rebuildTextCursor lc1 <> rebuildTextCursor lc2) isMovementM :: (TextCursor -> Maybe TextCursor) -> Property isMovementM func = @@ -115,14 +194,26 @@ let t = rebuildTextCursor tc t' = rebuildTextCursor tc' in unless (t == t') $ - expectationFailure $ - unlines - [ "Cursor before:\n" ++ show tc - , "Text before: \n" ++ show t - , "Cursor after: \n" ++ show tc' - , "Text after: \n" ++ show t' - ] + expectationFailure $ + unlines + [ "Cursor before:\n" ++ show tc, + "Text before: \n" ++ show t, + "Cursor after: \n" ++ show tc', + "Text after: \n" ++ show t' + ] isMovement :: (TextCursor -> TextCursor) -> Property isMovement func = forAllValid $ \lec -> rebuildTextCursor lec `shouldBe` rebuildTextCursor (func lec) + +isIdempotentForSentence :: (TextCursor -> TextCursor) -> Property +isIdempotentForSentence f = + checkCoverage $ + forAllShrink textCursorSentenceGen shrinkSentence $ \tc -> + let txt = rebuildTextCursor tc + numChars = T.length txt + numSpaces = T.length . T.filter isSpace $ txt + in cover 50 (numSpaces >= 1 && numChars > 2) "non trivial" $ f (f tc) `shouldBe` f tc + +buildTestTextCursor :: Text -> Text -> TextCursor +buildTestTextCursor befores afters = TextCursor {textCursorList = ListCursor {listCursorPrev = T.unpack . T.reverse $ befores, listCursorNext = T.unpack afters}} diff --git a/test/Cursor/Tree/TypesSpec.hs b/test/Cursor/Tree/TypesSpec.hs --- a/test/Cursor/Tree/TypesSpec.hs +++ b/test/Cursor/Tree/TypesSpec.hs @@ -1,21 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Tree.TypesSpec - ( spec - ) where + ( spec, + ) +where +import Cursor.Tree +import Cursor.Tree.Gen () import Test.Hspec - import Test.Validity import Test.Validity.Optics -import Cursor.Tree -import Cursor.Tree.Gen () - spec :: Spec spec = do eqSpec @TreeCursorSelection @@ -42,14 +41,14 @@ eqSpec @(TreeAbove Bool) genValidSpec @(TreeAbove Bool) shrinkValidSpecWithLimit @(TreeAbove Bool) 10 - describe "treeAboveLeftsL" $ lensSpecOnValid $ treeAboveLeftsL @Bool - describe "treeAboveAboveL" $ lensSpecOnValid $ treeAboveAboveL @Bool - describe "treeAboveNodeL" $ lensSpecOnValid $ treeAboveNodeL @Bool - describe "treeAboveRightsL" $ lensSpecOnValid $ treeAboveRightsL @Bool + describe "treeAboveLeftsL" $ lensSpec $ treeAboveLeftsL @Bool + describe "treeAboveAboveL" $ lensSpec $ treeAboveAboveL @Bool + describe "treeAboveNodeL" $ lensSpec $ treeAboveNodeL @Bool + describe "treeAboveRightsL" $ lensSpec $ treeAboveRightsL @Bool eqSpec @(TreeCursor Bool Word) genValidSpec @(TreeCursor Bool Bool) shrinkValidSpecWithLimit @(TreeCursor Word Bool) 10 - describe "treeCursorAboveL" $ lensSpecOnValid $ treeCursorAboveL @Bool @Bool - describe "treeCursorCurrentL" $ lensSpecOnValid $ treeCursorCurrentL @Bool @Bool - describe "treeCursorBelowL" $ lensSpecOnValid $ treeCursorBelowL @Bool @Bool - describe "treeCursorCurrentSubTreeL" $ lensSpecOnValid $ treeCursorCurrentSubTreeL @Bool @Bool + describe "treeCursorAboveL" $ lensSpec $ treeCursorAboveL @Bool @Bool + describe "treeCursorCurrentL" $ lensSpec $ treeCursorCurrentL @Bool @Bool + describe "treeCursorBelowL" $ lensSpec $ treeCursorBelowL @Bool @Bool + describe "treeCursorCurrentSubTreeL" $ lensSpec $ treeCursorCurrentSubTreeL @Bool @Bool