diff --git a/cursor-gen.cabal b/cursor-gen.cabal --- a/cursor-gen.cabal +++ b/cursor-gen.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 58018e9f00ff2eb5016098f09115ecf1aad35674f8b0a9ca7a893c923064ab31 +-- hash: f0096dc28a739f287cb2c184cec92b05547e888c6a4d33724be642b1f80124b2 name: cursor-gen -version: 0.0.0.0 +version: 0.1.0.0 synopsis: Generators for Purely Functional Cursors description: Generators for Purely Functional Cursors for common data structures category: Cursor @@ -16,9 +18,20 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 library + hs-source-dirs: + src/ + ghc-options: -Wall + build-depends: + QuickCheck + , base <5 + , containers + , cursor + , genvalidity >=0.8 + , genvalidity-containers + , genvalidity-text >=0.6 + , text exposed-modules: Cursor.Forest.Gen Cursor.List.Gen @@ -35,23 +48,26 @@ Cursor.Tree.Gen other-modules: Paths_cursor_gen + default-language: Haskell2010 + +test-suite cursor-test + type: exitcode-stdio-1.0 + main-is: Spec.hs hs-source-dirs: - src/ - ghc-options: -Wall + test/ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck - , base <5 + , base , containers , cursor - , genvalidity - , genvalidity-containers - , genvalidity-text + , cursor-gen + , genvalidity-hspec + , genvalidity-hspec-optics + , hspec + , microlens + , pretty-show , text - default-language: Haskell2010 - -test-suite cursor-test - type: exitcode-stdio-1.0 - main-is: Spec.hs other-modules: Cursor.List.NonEmptySpec Cursor.ListSpec @@ -74,19 +90,4 @@ Cursor.TextSpec Cursor.Tree.TypesSpec Paths_cursor_gen - hs-source-dirs: - test/ - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - build-depends: - QuickCheck - , base - , containers - , cursor - , cursor-gen - , genvalidity-hspec - , genvalidity-hspec-optics - , hspec - , microlens - , pretty-show - , text default-language: Haskell2010 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,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Forest.Gen - ( - ) where + ( + ) where import Data.GenValidity import Data.GenValidity.Containers () @@ -15,9 +15,9 @@ instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (ForestCursor a b) where - genUnchecked = ForestCursor <$> genUnchecked - shrinkUnchecked (ForestCursor ne) = ForestCursor <$> shrinkUnchecked ne + genUnchecked = ForestCursor <$> genUnchecked + shrinkUnchecked (ForestCursor ne) = ForestCursor <$> shrinkUnchecked ne instance (GenValid a, GenValid b) => GenValid (ForestCursor a b) where - genValid = ForestCursor <$> genValid - shrinkValid (ForestCursor ne) = ForestCursor <$> shrinkValid ne + genValid = ForestCursor <$> genValid + shrinkValid (ForestCursor ne) = ForestCursor <$> shrinkValid ne 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,9 +2,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.List.Gen - ( listCursorWithGen - , listCursorWithIndex0 - ) where + ( listCursorWithGen + , listCursorWithIndex0 + ) where import Test.QuickCheck @@ -13,20 +13,24 @@ 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 {..} + 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)] instance GenValid a => GenValid (ListCursor a) where - genValid = - sized $ \n -> do - (a, b) <- genSplit n - listCursorPrev <- resize a genValid - listCursorNext <- resize b genValid - pure ListCursor {..} + genValid = + sized $ \n -> do + (a, b) <- genSplit n + listCursorPrev <- resize a genValid + listCursorNext <- resize b genValid + pure ListCursor {..} + shrinkValid (ListCursor prev next) = + [ListCursor prev' next' | (prev', next') <- shrinkValid (prev, next)] listCursorWithGen :: Gen a -> Gen (ListCursor a) listCursorWithGen gen = ListCursor <$> genListOf gen <*> genListOf gen 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,10 +2,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.List.NonEmpty.Gen - ( nonEmptyElemOf - , nonEmptyWithIndex0 - , nonEmptyWith - ) where + ( nonEmptyElemOf + , nonEmptyWithIndex0 + , nonEmptyWith + ) where import Control.Monad @@ -19,34 +19,40 @@ instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (NonEmptyCursor a b) where - genUnchecked = - sized $ \n -> do - part <- arbPartition n - case part of - [] -> singletonNonEmptyCursor <$> resize 0 genUnchecked - (s:ss) -> do - i <- choose (0, length ss) - let (as, bs) = splitAt i ss - nonEmptyCursorPrev <- - forM as $ \s_ -> resize s_ genUnchecked - nonEmptyCursorCurrent <- resize s genUnchecked - nonEmptyCursorNext <- - forM bs $ \s_ -> resize s_ genUnchecked - pure NonEmptyCursor {..} + genUnchecked = + sized $ \n -> do + part <- arbPartition n + case part of + [] -> singletonNonEmptyCursor <$> resize 0 genUnchecked + (s:ss) -> do + i <- choose (0, length ss) + let (as, bs) = splitAt i ss + nonEmptyCursorPrev <- forM as $ \s_ -> resize s_ genUnchecked + nonEmptyCursorCurrent <- resize s genUnchecked + nonEmptyCursorNext <- forM bs $ \s_ -> resize s_ genUnchecked + pure NonEmptyCursor {..} + shrinkUnchecked (NonEmptyCursor prev cur next) = + [ NonEmptyCursor prev' cur' next' + | (prev', cur', next') <- shrinkUnchecked (prev, cur, next) + ] instance (GenValid a, GenValid b) => GenValid (NonEmptyCursor a b) where - genValid = - sized $ \n -> do - part <- arbPartition n - case part of - [] -> singletonNonEmptyCursor <$> resize 0 genValid - (s:ss) -> do - i <- choose (0, length ss) - let (as, bs) = splitAt i ss - nonEmptyCursorPrev <- forM as $ \s_ -> resize s_ genValid - nonEmptyCursorCurrent <- resize s genValid - nonEmptyCursorNext <- forM bs $ \s_ -> resize s_ genValid - pure NonEmptyCursor {..} + genValid = + sized $ \n -> do + part <- arbPartition n + case part of + [] -> singletonNonEmptyCursor <$> resize 0 genValid + (s:ss) -> do + i <- choose (0, length ss) + let (as, bs) = splitAt i ss + nonEmptyCursorPrev <- forM as $ \s_ -> resize s_ genValid + nonEmptyCursorCurrent <- resize s genValid + nonEmptyCursorNext <- forM bs $ \s_ -> resize s_ genValid + pure NonEmptyCursor {..} + shrinkValid (NonEmptyCursor prev cur next) = + [ NonEmptyCursor prev' cur' next' + | (prev', cur', next') <- shrinkValid (prev, cur, next) + ] nonEmptyElemOf :: NonEmptyCursor a a -> Gen a nonEmptyElemOf = elements . NE.toList . rebuildNonEmptyCursor id @@ -56,13 +62,13 @@ 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 - ] + oneof + [ NonEmptyCursor <$> listWithA <*> g <*> genListOf g + , NonEmptyCursor <$> genListOf g <*> pure a <*> genListOf g + , NonEmptyCursor <$> genListOf g <*> g <*> listWithA + ] where listWithA = do - l1 <- genListOf g - l2 <- genListOf g - pure $ l1 ++ [a] ++ l2 + l1 <- genListOf g + l2 <- genListOf g + pure $ l1 ++ [a] ++ l2 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 @@ -2,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Map.Gen - ( - ) where + ( + ) where import Data.GenValidity import Data.GenValidity.Containers () @@ -18,5 +18,5 @@ instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => GenValid (MapCursor kc vc k v) where - genValid = genValidStructurallyWithoutExtraChecking - shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering 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,8 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Map.KeyValue.Gen - ( - ) where + ( + ) where import Data.GenValidity @@ -13,8 +13,8 @@ instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => GenValid (KeyValueCursor kc vc k v) where - genValid = genValidStructurallyWithoutExtraChecking - shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance GenUnchecked KeyValueToggle 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,5 @@ 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,8 +1,8 @@ module Cursor.Simple.List.NonEmpty.Gen - ( nonEmptyElemOf - , nonEmptyWithIndex0 - , nonEmptyWith - ) where + ( nonEmptyElemOf + , nonEmptyWithIndex0 + , nonEmptyWith + ) where import Test.QuickCheck 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,5 @@ 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,5 @@ 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,5 @@ 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,9 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Text.Gen - ( textCursorWithGen - , textCursorWithIndex0 - ) where + ( textCursorWithGen + , textCursorWithIndex0 + ) where import Test.QuickCheck @@ -17,8 +17,8 @@ instance GenUnchecked TextCursor instance GenValid TextCursor where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally textCursorWithGen :: Gen Char -> Gen TextCursor textCursorWithGen gen = TextCursor <$> listCursorWithGen gen 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 @@ -14,14 +14,12 @@ import Cursor.List.NonEmpty.Gen () import Cursor.Text.Gen -instance GenUnchecked TextFieldCursor - instance GenValid TextFieldCursor where - genValid = do - let charGen = genValid `suchThat` (/= '\n') - prevs <- genListOf $ T.pack <$> genListOf charGen - nexts <- genListOf $ T.pack <$> genListOf charGen - cur <- textCursorWithGen charGen - let nec = NonEmptyCursor prevs cur nexts - pure $ TextFieldCursor nec - shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + genValid = do + let charGen = genValid `suchThat` (/= '\n') + prevs <- genListOf $ T.pack <$> genListOf charGen + nexts <- genListOf $ T.pack <$> genListOf charGen + cur <- textCursorWithGen charGen + let nec = NonEmptyCursor prevs cur nexts + pure $ TextFieldCursor nec + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering 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 @@ -3,8 +3,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Tree.Gen - ( - ) where + ( + ) where import qualified Data.List.NonEmpty as NE import Data.Maybe @@ -19,136 +19,135 @@ instance GenUnchecked TreeCursorSelection instance GenValid TreeCursorSelection where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally instance GenUnchecked a => GenUnchecked (SwapResult a) instance GenValid a => GenValid (SwapResult a) where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally instance GenUnchecked a => GenUnchecked (PromoteElemResult a) instance GenValid a => GenValid (PromoteElemResult a) where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally instance GenUnchecked a => GenUnchecked (PromoteResult a) instance GenValid a => GenValid (PromoteResult a) where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally instance GenUnchecked a => GenUnchecked (DemoteResult a) instance GenValid a => GenValid (DemoteResult a) where - genValid = genValidStructurally - shrinkValid = shrinkValidStructurally + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally instance GenUnchecked a => GenUnchecked (CTree a) where - genUnchecked = - sized $ \n -> do - s <- upTo n - (a, b) <- genSplit s - val <- resize a genUnchecked - for <- resize b genUnchecked - pure $ CNode val for - shrinkUnchecked (CNode a cf) = - [CNode a' cf' | (a', cf') <- shrinkUnchecked (a, cf)] + genUnchecked = + sized $ \n -> do + s <- upTo n + (a, b) <- genSplit s + 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 - s <- upTo n - (a, b) <- genSplit s - val <- resize a genValid - for <- resize b genValid - pure $ CNode val for - shrinkValid (CNode a cf) = [CNode a' cf' | (a', cf') <- shrinkValid (a, cf)] + genValid = + sized $ \n -> do + s <- upTo n + (a, b) <- genSplit s + val <- resize a genValid + for <- resize b genValid + 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 $ \n -> - case n of - 0 -> pure EmptyCForest - _ -> - oneof - [ ClosedForest <$> resize n genUnchecked - , OpenForest <$> resize n genUnchecked - ] - shrinkUnchecked EmptyCForest = [] - shrinkUnchecked (ClosedForest ne) = - EmptyCForest : (ClosedForest <$> shrinkUnchecked ne) - shrinkUnchecked (OpenForest ne) = - EmptyCForest : - ClosedForest (NE.map rebuildCTree ne) : - (OpenForest <$> shrinkUnchecked ne) + genUnchecked = + sized $ \n -> + case n of + 0 -> pure EmptyCForest + _ -> + oneof + [ ClosedForest <$> resize n genUnchecked + , OpenForest <$> resize n 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 $ \n -> - case n of - 0 -> pure EmptyCForest - _ -> - oneof - [ ClosedForest <$> resize n genValid - , OpenForest <$> resize n genValid - ] - shrinkValid EmptyCForest = [] - shrinkValid (ClosedForest ne) = - EmptyCForest : (ClosedForest <$> shrinkValid ne) - shrinkValid (OpenForest ne) = - EmptyCForest : - ClosedForest (NE.map rebuildCTree ne) : (OpenForest <$> shrinkValid ne) + genValid = + sized $ \n -> + case n of + 0 -> pure EmptyCForest + _ -> + oneof + [ ClosedForest <$> resize n genValid + , OpenForest <$> resize n genValid + ] + shrinkValid EmptyCForest = [] + shrinkValid (ClosedForest ne) = + EmptyCForest : (ClosedForest <$> shrinkValid ne) + 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 + 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 - s <- upTo n - (a, b, c, d) <- genSplit4 s - treeAbove <- resize (a + b) genValid - treeCurrent <- resize c genValid - treeBelow <- resize d genValid - pure TreeCursor {..} - shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + genValid = + sized $ \n -> do + s <- upTo n + (a, b, c, d) <- genSplit4 s + treeAbove <- resize (a + b) genValid + treeCurrent <- resize c genValid + 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 {..} + 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 = - sized $ \n -> do - s <- upTo n - (a, b, c, d) <- genSplit4 s - treeAboveLefts <- resize a genValid - treeAboveAbove <- resize b genValid - treeAboveNode <- resize c genValid - treeAboveRights <- resize d genValid - pure TreeAbove {..} - shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + genValid = + sized $ \n -> do + s <- upTo n + (a, b, c, d) <- genSplit4 s + treeAboveLefts <- resize a genValid + treeAboveAbove <- resize b genValid + treeAboveNode <- resize c genValid + treeAboveRights <- resize d genValid + pure TreeAbove {..} + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering 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 @@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.List.NonEmptySpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.Validity @@ -17,15 +17,13 @@ spec :: Spec spec = do - describe "nonemptyPrepend" $ - it "is equivalent to regular prepend" $ - equivalentWhenFirstSucceeds - (\(ls1, ls2) -> - (NE.toList . nonemptyPrepend ls1) <$> NE.nonEmpty ls2) - (uncurry (++) :: ([Int], [Int]) -> [Int]) - describe "nonemptyAppend" $ - it "is equivalent to regular append" $ - equivalentWhenFirstSucceeds - (\(ls1, ls2) -> - (NE.toList . (`nonemptyAppend` ls2)) <$> NE.nonEmpty ls1) - (uncurry (++) :: ([Int], [Int]) -> [Int]) + describe "nonemptyPrepend" $ + it "is equivalent to regular prepend" $ + equivalentWhenFirstSucceeds + (\(ls1, ls2) -> (NE.toList . nonemptyPrepend ls1) <$> NE.nonEmpty ls2) + (uncurry (++) :: ([Int], [Int]) -> [Int]) + describe "nonemptyAppend" $ + it "is equivalent to regular append" $ + equivalentWhenFirstSucceeds + (\(ls1, ls2) -> (NE.toList . (`nonemptyAppend` ls2)) <$> NE.nonEmpty ls1) + (uncurry (++) :: ([Int], [Int]) -> [Int]) diff --git a/test/Cursor/ListSpec.hs b/test/Cursor/ListSpec.hs --- a/test/Cursor/ListSpec.hs +++ b/test/Cursor/ListSpec.hs @@ -3,8 +3,8 @@ {-# LANGUAGE RankNTypes #-} module Cursor.ListSpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -17,126 +17,123 @@ spec :: Spec spec = do - eqSpec @(ListCursor Int) - functorSpec @ListCursor - genValidSpec @(ListCursor Double) - describe "emptyListCursor" $ - it "is valid" $ shouldBeValid (emptyListCursor @Int) - describe "makeListCursor" $ - it "produces valid list cursors" $ - producesValidsOnValids (makeListCursor @Double) - describe "makeListCursorWithSelection" $ - it "produces valid list cursors" $ - producesValidsOnValids2 (makeListCursorWithSelection @Double) - describe "rebuildListCursor" $ do - it "produces valid lists" $ - producesValidsOnValids (rebuildListCursor @Double) - it "is the inverse of makeListCursor" $ - inverseFunctions (makeListCursor @Int) rebuildListCursor - it "is the inverse of makeListCursorWithSelection for any index" $ - forAllUnchecked $ \i -> - inverseFunctionsIfFirstSucceeds - (makeListCursorWithSelection @Int i) - rebuildListCursor - describe "listCursorNull" $ - it "produces valid bools" $ - producesValidsOnValids (listCursorNull @Double) - describe "listCursorLength" $ - it "produces valid bools" $ - producesValidsOnValids (listCursorLength @Double) - describe "listCursorIndex" $ - it "produces valid indices" $ - producesValidsOnValids (listCursorIndex @Double) - describe "listCursorSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids (listCursorSelectPrev @Double) - it "is a movement" $ isMovementM listCursorSelectPrev - it "selects the previous position" pending - describe "listCursorSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids (listCursorSelectNext @Double) - it "is a movement" $ isMovementM listCursorSelectNext - it "selects the next position" pending - describe "listCursorSelectIndex" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (listCursorSelectIndex @Double) - it "is a movement" $ - forAllUnchecked $ \ix -> isMovement (listCursorSelectIndex ix) - it "selects the position at the given index" pending - describe "listCursorPrevItem" $ do - it "produces valid items" $ - producesValidsOnValids (listCursorPrevItem @Double) - it "returns the item before the position" pending - describe "listCursorNextItem" $ do - it "produces valid items" $ - producesValidsOnValids (listCursorNextItem @Double) - it "returns the item after the position" pending - describe "listCursorSelectStart" $ do - it "produces valid cursors" $ - producesValidsOnValids (listCursorSelectStart @Double) - it "is a movement" $ isMovement listCursorSelectStart - it "is idempotent" $ idempotentOnValid (listCursorSelectStart @Double) - it "selects the starting position" pending - describe "listCursorSelectEnd" $ do - it "produces valid cursors" $ - producesValidsOnValids (listCursorSelectEnd @Double) - it "is a movement" $ isMovement listCursorSelectEnd - it "is idempotent" $ idempotentOnValid (listCursorSelectEnd @Double) - it "selects the end position" pending - describe "listCursorInsert" $ do - it "produces valids" $ - forAllValid $ \d -> - producesValidsOnValids (listCursorInsert @Double d) - it "inserts an item before the cursor" $ pending - describe "listCursorAppend" $ do - it "produces valids" $ - forAllValid $ \d -> - producesValidsOnValids (listCursorAppend @Double d) - it "inserts an item after the cursor" $ pending - describe "listCursorRemove" $ do - it "produces valids" $ validIfSucceedsOnValid (listCursorRemove @Double) - it "removes an item before the cursor" $ pending - describe "listCursorDelete" $ do - it "produces valids" $ validIfSucceedsOnValid (listCursorDelete @Double) - it "removes an item before the cursor" $ pending - describe "listCursorSplit" $ do - it "produces valids" $ producesValidsOnValids (listCursorSplit @Double) - it - "produces two list cursors that rebuild to the rebuilding of the original" $ - forAllValid $ \lc -> - let (lc1, lc2) = listCursorSplit (lc :: ListCursor Double) - in (rebuildListCursor lc1 ++ rebuildListCursor lc2) `shouldBe` - rebuildListCursor lc - describe "listCursorCombine" $ do - it "produces valids" $ - producesValidsOnValids2 (listCursorCombine @Double) - it - "produces a list that rebuilds to the rebuilding of the original two cursors" $ - forAllValid $ \lc1 -> - forAllValid $ \lc2 -> - let lc = listCursorCombine lc1 (lc2 :: ListCursor Double) - in rebuildListCursor lc `shouldBe` - (rebuildListCursor lc1 ++ rebuildListCursor lc2) + eqSpec @(ListCursor Int) + functorSpec @ListCursor + genValidSpec @(ListCursor Rational) + describe "emptyListCursor" $ + it "is valid" $ shouldBeValid (emptyListCursor @Int) + describe "makeListCursor" $ + it "produces valid list cursors" $ + producesValidsOnValids (makeListCursor @Rational) + describe "makeListCursorWithSelection" $ + it "produces valid list cursors" $ + producesValidsOnValids2 (makeListCursorWithSelection @Rational) + describe "rebuildListCursor" $ do + it "produces valid lists" $ + producesValidsOnValids (rebuildListCursor @Rational) + it "is the inverse of makeListCursor" $ + inverseFunctions (makeListCursor @Int) rebuildListCursor + it "is the inverse of makeListCursorWithSelection for any index" $ + forAllUnchecked $ \i -> + inverseFunctionsIfFirstSucceeds + (makeListCursorWithSelection @Int i) + rebuildListCursor + describe "listCursorNull" $ + it "produces valid bools" $ + producesValidsOnValids (listCursorNull @Rational) + describe "listCursorLength" $ + it "produces valid bools" $ + producesValidsOnValids (listCursorLength @Rational) + describe "listCursorIndex" $ + it "produces valid indices" $ + producesValidsOnValids (listCursorIndex @Rational) + describe "listCursorSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (listCursorSelectPrev @Rational) + it "is a movement" $ isMovementM listCursorSelectPrev + it "selects the previous position" pending + describe "listCursorSelectNext" $ do + it "produces valid cursors" $ + producesValidsOnValids (listCursorSelectNext @Rational) + it "is a movement" $ isMovementM listCursorSelectNext + it "selects the next position" pending + describe "listCursorSelectIndex" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (listCursorSelectIndex @Rational) + it "is a movement" $ + forAllUnchecked $ \ix -> isMovement (listCursorSelectIndex ix) + it "selects the position at the given index" pending + describe "listCursorPrevItem" $ do + it "produces valid items" $ + producesValidsOnValids (listCursorPrevItem @Rational) + it "returns the item before the position" pending + describe "listCursorNextItem" $ do + it "produces valid items" $ + producesValidsOnValids (listCursorNextItem @Rational) + it "returns the item after the position" pending + describe "listCursorSelectStart" $ do + it "produces valid cursors" $ + producesValidsOnValids (listCursorSelectStart @Rational) + it "is a movement" $ isMovement listCursorSelectStart + it "is idempotent" $ idempotentOnValid (listCursorSelectStart @Rational) + it "selects the starting position" pending + describe "listCursorSelectEnd" $ do + it "produces valid cursors" $ + producesValidsOnValids (listCursorSelectEnd @Rational) + it "is a movement" $ isMovement listCursorSelectEnd + it "is idempotent" $ idempotentOnValid (listCursorSelectEnd @Rational) + it "selects the end position" pending + describe "listCursorInsert" $ do + it "produces valids" $ + forAllValid $ \d -> producesValidsOnValids (listCursorInsert @Rational d) + it "inserts an item before the cursor" $ pending + describe "listCursorAppend" $ do + it "produces valids" $ + forAllValid $ \d -> producesValidsOnValids (listCursorAppend @Rational d) + it "inserts an item after the cursor" $ pending + describe "listCursorRemove" $ do + it "produces valids" $ validIfSucceedsOnValid (listCursorRemove @Rational) + it "removes an item before the cursor" $ pending + describe "listCursorDelete" $ do + it "produces valids" $ validIfSucceedsOnValid (listCursorDelete @Rational) + it "removes an item before the cursor" $ pending + describe "listCursorSplit" $ do + it "produces valids" $ producesValidsOnValids (listCursorSplit @Rational) + it + "produces two list cursors that rebuild to the rebuilding of the original" $ + forAllValid $ \lc -> + let (lc1, lc2) = listCursorSplit (lc :: ListCursor Rational) + in (rebuildListCursor lc1 ++ rebuildListCursor lc2) `shouldBe` + rebuildListCursor lc + describe "listCursorCombine" $ do + it "produces valids" $ producesValidsOnValids2 (listCursorCombine @Rational) + it + "produces a list that rebuilds to the rebuilding of the original two cursors" $ + forAllValid $ \lc1 -> + forAllValid $ \lc2 -> + let lc = listCursorCombine lc1 (lc2 :: ListCursor Rational) + in rebuildListCursor lc `shouldBe` + (rebuildListCursor lc1 ++ rebuildListCursor lc2) isMovementM :: (forall a. ListCursor a -> Maybe (ListCursor a)) -> Property isMovementM func = - forAllValid $ \lec -> - case func (lec :: ListCursor Int) of - Nothing -> pure () -- Fine - Just lec' -> - 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' - ] + forAllValid $ \lec -> + case func (lec :: ListCursor Int) of + Nothing -> pure () -- Fine + Just lec' -> + 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' + ] isMovement :: (forall a. ListCursor a -> ListCursor a) -> Property isMovement func = - forAllValid $ \lec -> - rebuildListCursor (lec :: ListCursor Int) `shouldBe` - rebuildListCursor (func lec) + forAllValid $ \lec -> + rebuildListCursor (lec :: ListCursor Int) `shouldBe` + rebuildListCursor (func lec) 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,8 +1,8 @@ {-# LANGUAGE TypeApplications #-} module Cursor.Map.KeyValueSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -13,7 +13,7 @@ spec :: Spec spec = do - eqSpec @(KeyValueCursor Int Int Int Int) - genValidSpec @(KeyValueCursor Double Double Double Double) - eqSpec @KeyValueToggle - genValidSpec @KeyValueToggle + eqSpec @(KeyValueCursor Int Int Int Int) + genValidSpec @(KeyValueCursor Double Double Double Double) + eqSpec @KeyValueToggle + genValidSpec @KeyValueToggle diff --git a/test/Cursor/MapSpec.hs b/test/Cursor/MapSpec.hs --- a/test/Cursor/MapSpec.hs +++ b/test/Cursor/MapSpec.hs @@ -3,8 +3,8 @@ {-# LANGUAGE RankNTypes #-} module Cursor.MapSpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.Validity @@ -14,6 +14,6 @@ spec :: Spec spec = do - eqSpec @(MapCursor Word Int Bool Ordering) - genValidSpec @(MapCursor Double Rational Int Bool) - shrinkValidSpec @(MapCursor Double Rational Int Bool) + eqSpec @(MapCursor Word Int Bool Ordering) + genValidSpec @(MapCursor Double Rational Int Bool) + shrinkValidSpec @(MapCursor Double Rational Int Bool) 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 @@ -4,1011 +4,920 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.ForestSpec - ( spec - ) where - -import Data.Tree - -import Control.Monad (unless) - -import Test.Hspec - -import Test.QuickCheck -import Test.Validity -import Test.Validity.Optics - -import Cursor.Forest (ForestCursor(..)) -import Cursor.List.NonEmpty -import Cursor.Simple.Forest hiding (ForestCursor) -import qualified Cursor.Simple.Forest as SFC (ForestCursor) -import Cursor.Tree -import Cursor.Types - -import Cursor.Simple.Forest.Gen () - -spec :: Spec -spec = do - eqSpec @(SFC.ForestCursor Int) - genValidSpec @(SFC.ForestCursor Double) - shrinkValidSpecWithLimit @(SFC.ForestCursor Double) 100 - describe "makeForestCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (makeForestCursor @Double) - describe "rebuildForestCursor" $ do - it "produces valid forests" $ - producesValidsOnValids (rebuildForestCursor @Double) - it "is the inverse of makeForestCursor for integers" $ - inverseFunctions (makeForestCursor @Int) rebuildForestCursor - describe "forestCursorLestCursorL" $ - lensSpecOnValid (forestCursorListCursorL @Double @Double) - describe "forestCursorSelectedTreeL" $ - lensSpecOnValid (forestCursorSelectedTreeL @Double @Double) - describe "forestCursorSelection" $ do - it "produces valid ints" $ - producesValidsOnValids (forestCursorSelection @Double @Double) - it "returns the index of the currently selected element" pending - describe "forestCursorSelectIndex" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorSelectIndex @Double) - it "is the identity function when given the current selection" $ - forAllValid $ \fc -> - forestCursorSelectIndex (forestCursorSelection fc) fc `shouldBe` - Just (fc :: SFC.ForestCursor Double) - it "returns selects the element at the given index" pending - movementsSpec - collapseSpec - insertSpec - swapSpec - deleteSpec - shiftingSpec - -movementsSpec :: Spec -movementsSpec = do - describe "forestCursorSelectPrevTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectPrevTreeCursor @Double - it "is a movement" $ isMovementM forestCursorSelectPrevTreeCursor - it "selects the previous tree cursor" pending - describe "forestCursorSelectNextTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectNextTreeCursor @Double - it "is a movement" $ isMovementM forestCursorSelectNextTreeCursor - it "selects the next tree" pending - describe "forestCursorSelectFirstTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectFirstTreeCursor @Double - it "is a movement" $ isMovement forestCursorSelectFirstTreeCursor - it "selects the first tree" pending - describe "forestCursorSelectLastTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectLastTreeCursor @Double - it "is a movement" $ isMovement forestCursorSelectLastTreeCursor - it "selects the last tree" pending - describe "forestCursorSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectPrev @Double - it "is a movement" $ isMovementM forestCursorSelectPrev - it "selects the previous node" pending - -- 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 - describe "forestCursorSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectNext @Double - 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 - describe "forestCursorSelectPrevOnSameLevel" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectPrevOnSameLevel @Double - 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 @Double - it "is a movement" $ isMovementM forestCursorSelectNextOnSameLevel - it "selects the next node on the same level as the current node" pending - describe "forestCursorSelectFirst" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectFirst @Double - it "is a movement" $ isMovement forestCursorSelectFirst - it "selects the first node in the forest" pending - describe "forestCursorSelectLast" $ do - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorSelectLast @Double - it "is a movement" $ isMovement forestCursorSelectLast - it "selects the last node in the forest" pending - describe "forestCursorSelectBelowAtPos" $ do - it "produces valid cursors" $ - producesValidsOnValids2 $ forestCursorSelectBelowAtPos @Double - it "is a movement for any index" $ - 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 @Double - 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 @Double - 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 @Double @Double - describe "forestCursorCloseCurrentForest" $ - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorCloseCurrentForest @Double @Double - describe "forestCursorToggleCurrentForest" $ - it "produces valid cursors" $ - producesValidsOnValids $ forestCursorToggleCurrentForest @Double @Double - -insertSpec :: Spec -insertSpec = do - describe "forestCursorInsertEntireTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 - (forestCursorInsertEntireTree @Double @Double) - it - "inserts a tree cursor before the currently selected tree cursor" - pending - describe "forestCursorInsertAndSelectTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids2 - (forestCursorInsertAndSelectTreeCursor @Double) - it - "inserts a tree cursor before the currently selected tree cursor and selects it" - pending - describe "forestCursorAppendEntireTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 - (forestCursorAppendEntireTree @Double @Double) - it "appends a tree after the currently selected tree cursor" pending - describe "forestCursorAppendAndSelectTreeCursor" $ do - it "produces valid cursors" $ - producesValidsOnValids2 - (forestCursorAppendAndSelectTreeCursor @Double) - it - "appends a tree cursor after the currently selected tree cursor and selects it" - pending - describe "forestCursorInsertTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorInsertTree @Double @Double) - it "inserts a tree before the currently selected tree" pending - describe "forestCursorInsertAndSelectTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorInsertAndSelectTree @Double) - it - "inserts a tree before the currently selected tree and selects it" - pending - describe "forestCursorAppendTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAppendTree @Double @Double) - it "appends a tree after the currently selected tree " pending - describe "forestCursorAppendAndSelectTree" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAppendAndSelectTree @Double) - it - "appends a tree after the currently selected tree and selects it" - pending - describe "forestCursorInsert" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorInsert @Double @Double) - it "inserts a node before the currently selected node" pending - describe "forestCursorInsertAndSelect" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorInsertAndSelect @Double) - it - "inserts a node before the currently selected node and selects it" - pending - describe "forestCursorAppend" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAppend @Double @Double) - it "appends a node after the currently selected node" pending - describe "forestCursorAppendAndSelect" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAppendAndSelect @Double) - it - "appends a node after the currently selected node and selects it" - pending - describe "forestCursorAddChildTreeToNodeAtPos" $ do - it "produces valid cursors" $ - producesValidsOnValids3 $ - forestCursorAddChildTreeToNodeAtPos @Double @Double - 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 @Double @Double - 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 @Double @Double - 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 @Double @Double - 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 @Double @Double - 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 @Double @Double - it "adds a child to a node at the end the children of that node" pending - describe "forestCursorAddRoot" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (forestCursorAddRoot @Double) - it "houses the entire forest under the given node" pending - -swapSpec :: Spec -swapSpec = do - describe "forestCursorSwapPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorSwapPrev @Double @Double) - it "works on the example from the docs" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [CNode 'a' $ emptyCForest] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'b' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [] - } - } - end = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'b' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = - [CNode 'a' $ emptyCForest] - } - } - in case forestCursorSwapPrev start of - Nothing -> - expectationFailure - "forestCursorSwapPrev should not have failed." - Just r -> r `forestShouldBe` end - it - "swaps the current node with the previous node on the same level" - pending - it "reverts forestCursorSwapNext" $ - inverseFunctionsIfSucceedOnValid - (forestCursorSwapNext @Double @Double) - (forestCursorSwapPrev @Double @Double) - describe "forestCursorSwapNext" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorSwapNext @Double @Double) - it "works on the example from the docs" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'a' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = - [CNode 'b' $ emptyCForest] - } - } - end = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [CNode 'b' $ emptyCForest] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'a' - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorSwapNext start of - Nothing -> - expectationFailure - "forestCursorSwapNext should not have failed." - Just r -> r `forestShouldBe` end - it "swaps the current node with the next node on the same level" pending - it "reverts forestCursorSwapPrev" $ - inverseFunctionsIfSucceedOnValid - (forestCursorSwapPrev @Double @Double) - (forestCursorSwapNext @Double @Double) - -deleteSpec :: Spec -deleteSpec = do - describe "forestCursorRemoveElemAndSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorRemoveElemAndSelectPrev @Double) - it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 :: Int - , treeBelow = - closedForest [Node 2 fs] - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorRemoveElemAndSelectPrev - simpleDeleteElemStart of - Nothing -> pure () - Just Deleted -> - expectationFailure - "forestCursorRemoveElemAndSelectPrev should not have deleted the entire example forest." - Just (Updated _) -> - expectationFailure - "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 @Double) - 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 - it "deletes the selected element and selects the next element" pending - describe "forestCursorRemoveElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorRemoveElem @Double) - 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 - it "removes the selected element" pending - describe "forestCursorDeleteElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorDeleteElem @Double) - 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 - it "deletes the selected element" pending - describe "forestCursorRemoveSubTreeAndSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids - (forestCursorRemoveSubTreeAndSelectPrev @Double) - it "removes the selected subtree and selects the previous tree" pending - describe "forestCursorDeleteSubTreeAndSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids - (forestCursorDeleteSubTreeAndSelectNext @Double) - it "deletes the selected subtree and selects the next tree" pending - describe "forestCursorRemoveSubTree" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorRemoveSubTree @Double) - it "removes the selected subtree" pending - describe "forestCursorDeleteSubTree" $ do - it "produces valid cursors" $ - producesValidsOnValids (forestCursorDeleteSubTree @Double) - it "deletes the selected subtree" pending - -shiftingSpec :: Spec -shiftingSpec = do - describe "forestCursorPromoteElem" $ do - it "produces valids on valids" $ - producesValidsOnValids $ forestCursorPromoteElem @Double - it "works on the example from the documentation" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { 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] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [ CNode 'a' $ - 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] - } - } - in case forestCursorPromoteElem start of - Nothing -> - expectationFailure - "forestCursorPromoteElem should not have failed." - 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 @Double - it "works on the example from the documentation" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [CNode 'a' $ closedForest [Node 'b' []]] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'c' - , treeBelow = - closedForest [Node 'd' []] - } - , nonEmptyCursorNext = - [CNode 'e' emptyCForest] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { 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] - } - } - in case forestCursorDemoteElem start of - Nothing -> - expectationFailure - "forestCursorDemoteElem should not have failed." - 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 @Double - it "works on the example from the documentation" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { 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] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [ CNode 'a' $ - 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] - } - } - in case forestCursorPromoteSubTree start of - Nothing -> - expectationFailure - "forestCursorPromoteSubTree should not have failed." - 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 @Double - it "works on the example from the documentation" $ - let start = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = - [CNode 'a' $ closedForest [Node 'b' []]] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 'c' - , treeBelow = - closedForest [Node 'd' []] - } - , nonEmptyCursorNext = [] - } - } - expected = - ForestCursor - { forestCursorListCursor = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = - [ CNode - 'b' - emptyCForest - ] - , treeAboveAbove = - Nothing - , treeAboveNode = 'a' - , treeAboveRights = [] - } - , treeCurrent = 'c' - , treeBelow = - closedForest [Node 'd' []] - } - , nonEmptyCursorNext = [] - } - } - in case forestCursorDemoteSubTree start of - Nothing -> - expectationFailure - "forestCursorDemoteSubTree should not have failed." - Just f -> f `forestShouldBe` expected - it "demotes the current subtree to the level of its children" pending - describe "forestCursorDemoteElemUnder" $ do - it "produces valids on valids" $ - producesValidsOnValids3 $ - forestCursorDemoteElemUnder @Double @Double - 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 - it "demotes the current node to the level of its children" pending - describe "forestCursorDemoteSubTreeUnder" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ - forestCursorDemoteSubTreeUnder @Double @Double - 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 - 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 -isMovementM func = - forAllValid @(SFC.ForestCursor Int) $ \lec -> - case func lec of - Nothing -> pure () -- Fine - Just lec' -> - 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' - ] - -isMovement :: (forall a. SFC.ForestCursor a -> SFC.ForestCursor a) -> Property -isMovement func = - forAllValid $ \lec -> - rebuildForestCursor (lec :: SFC.ForestCursor Int) `shouldBe` - rebuildForestCursor (func lec) - -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 - ] + ( spec + ) where + +import Data.Tree + +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.List.NonEmpty +import Cursor.Simple.Forest hiding (ForestCursor) +import qualified Cursor.Simple.Forest as SFC (ForestCursor) +import Cursor.Tree +import Cursor.Types + +import Cursor.Simple.Forest.Gen () + +spec :: Spec +spec = do + eqSpec @(SFC.ForestCursor Int) + genValidSpec @(SFC.ForestCursor Rational) + modifyMaxSize (`quot` 2) $ + modifyMaxSuccess (`quot` 2) $ + shrinkValidSpecWithLimit @(SFC.ForestCursor Rational) 10 + describe "makeForestCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (makeForestCursor @Rational) + describe "rebuildForestCursor" $ do + it "produces valid forests" $ + producesValidsOnValids (rebuildForestCursor @Rational) + it "is the inverse of makeForestCursor for integers" $ + inverseFunctions (makeForestCursor @Int) rebuildForestCursor + describe "forestCursorLestCursorL" $ + lensSpecOnValid (forestCursorListCursorL @Rational @Rational) + describe "forestCursorSelectedTreeL" $ + lensSpecOnValid (forestCursorSelectedTreeL @Rational @Rational) + describe "forestCursorSelection" $ do + it "produces valid ints" $ + producesValidsOnValids (forestCursorSelection @Rational @Rational) + it "returns the index of the currently selected element" pending + describe "forestCursorSelectIndex" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorSelectIndex @Rational) + it "is the identity function when given the current selection" $ + forAllValid $ \fc -> + forestCursorSelectIndex (forestCursorSelection fc) fc `shouldBe` + Just (fc :: SFC.ForestCursor Rational) + it "returns selects the element at the given index" pending + movementsSpec + collapseSpec + insertSpec + swapSpec + deleteSpec + shiftingSpec + +movementsSpec :: Spec +movementsSpec = do + describe "forestCursorSelectPrevTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectPrevTreeCursor @Rational + it "is a movement" $ isMovementM forestCursorSelectPrevTreeCursor + it "selects the previous tree cursor" pending + describe "forestCursorSelectNextTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectNextTreeCursor @Rational + it "is a movement" $ isMovementM forestCursorSelectNextTreeCursor + it "selects the next tree" pending + describe "forestCursorSelectFirstTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectFirstTreeCursor @Rational + it "is a movement" $ isMovement forestCursorSelectFirstTreeCursor + it "selects the first tree" pending + describe "forestCursorSelectLastTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectLastTreeCursor @Rational + it "is a movement" $ isMovement forestCursorSelectLastTreeCursor + it "selects the last tree" pending + describe "forestCursorSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectPrev @Rational + it "is a movement" $ isMovementM forestCursorSelectPrev + it "selects the previous node" pending + -- 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 + describe "forestCursorSelectNext" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectNext @Rational + 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 + describe "forestCursorSelectPrevOnSameLevel" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectPrevOnSameLevel @Rational + 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 @Rational + it "is a movement" $ isMovementM forestCursorSelectNextOnSameLevel + it "selects the next node on the same level as the current node" pending + describe "forestCursorSelectFirst" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectFirst @Rational + it "is a movement" $ isMovement forestCursorSelectFirst + it "selects the first node in the forest" pending + describe "forestCursorSelectLast" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectLast @Rational + it "is a movement" $ isMovement forestCursorSelectLast + it "selects the last node in the forest" pending + describe "forestCursorSelectAbove" $ do + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorSelectAbove @Rational + it "is a movement" $ isMovementM forestCursorSelectAbove + it "selects the parent" pending + describe "forestCursorSelectBelowAtPos" $ do + it "produces valid cursors" $ + producesValidsOnValids2 $ forestCursorSelectBelowAtPos @Rational + it "is a movement for any index" $ + 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 @Rational + 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 @Rational + 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 @Rational @Rational + describe "forestCursorCloseCurrentForest" $ + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorCloseCurrentForest @Rational @Rational + describe "forestCursorToggleCurrentForest" $ + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorToggleCurrentForest @Double @Double + describe "forestCursorOpenCurrentForestRecursively" $ + it "produces valid cursors" $ + producesValidsOnValids $ forestCursorToggleCurrentForest @Rational @Rational + describe "forestCursorToggleCurrentForestRecursively" $ + it "produces valid cursors" $ + producesValidsOnValids $ + forestCursorToggleCurrentForestRecursively @Rational @Rational + +insertSpec :: Spec +insertSpec = do + describe "forestCursorInsertEntireTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsertEntireTree @Rational @Rational) + it "inserts a tree cursor before the currently selected tree cursor" pending + describe "forestCursorInsertAndSelectTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsertAndSelectTreeCursor @Rational) + it + "inserts a tree cursor before the currently selected tree cursor and selects it" + pending + describe "forestCursorAppendEntireTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppendEntireTree @Rational @Rational) + it "appends a tree after the currently selected tree cursor" pending + describe "forestCursorAppendAndSelectTreeCursor" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppendAndSelectTreeCursor @Rational) + it + "appends a tree cursor after the currently selected tree cursor and selects it" + pending + describe "forestCursorInsertTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsertTree @Rational @Rational) + it "inserts a tree before the currently selected tree" pending + describe "forestCursorInsertAndSelectTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsertAndSelectTree @Rational) + it + "inserts a tree before the currently selected tree and selects it" + pending + describe "forestCursorAppendTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppendTree @Rational @Rational) + it "appends a tree after the currently selected tree " pending + describe "forestCursorAppendAndSelectTree" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppendAndSelectTree @Rational) + it "appends a tree after the currently selected tree and selects it" pending + describe "forestCursorInsert" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsert @Rational @Rational) + it "inserts a node before the currently selected node" pending + describe "forestCursorInsertAndSelect" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorInsertAndSelect @Rational) + it + "inserts a node before the currently selected node and selects it" + pending + describe "forestCursorAppend" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppend @Rational @Rational) + it "appends a node after the currently selected node" pending + describe "forestCursorAppendAndSelect" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAppendAndSelect @Rational) + it "appends a node after the currently selected node and selects it" pending + describe "forestCursorAddChildTreeToNodeAtPos" $ do + it "produces valid cursors" $ + producesValidsOnValids3 $ + forestCursorAddChildTreeToNodeAtPos @Rational @Rational + 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 @Rational @Rational + 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 @Rational @Rational + 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 @Rational @Rational + 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 @Rational @Rational + 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 @Rational @Rational + it "adds a child to a node at the end the children of that node" pending + describe "forestCursorAddRoot" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (forestCursorAddRoot @Rational) + it "houses the entire forest under the given node" pending + +swapSpec :: Spec +swapSpec = do + describe "forestCursorSwapPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorSwapPrev @Rational @Rational) + it "works on the example from the docs" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [CNode 'a' $ emptyCForest] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'b' + , treeBelow = emptyCForest + } + , nonEmptyCursorNext = [] + } + } + end = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'b' + , treeBelow = emptyCForest + } + , nonEmptyCursorNext = [CNode 'a' $ emptyCForest] + } + } + in case forestCursorSwapPrev start of + Nothing -> + expectationFailure "forestCursorSwapPrev should not have failed." + Just r -> r `forestShouldBe` end + it "swaps the current node with the previous node on the same level" pending + it "reverts forestCursorSwapNext" $ + inverseFunctionsIfSucceedOnValid + (forestCursorSwapNext @Rational @Rational) + (forestCursorSwapPrev @Rational @Rational) + describe "forestCursorSwapNext" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorSwapNext @Rational @Rational) + it "works on the example from the docs" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'a' + , treeBelow = emptyCForest + } + , nonEmptyCursorNext = [CNode 'b' $ emptyCForest] + } + } + end = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [CNode 'b' $ emptyCForest] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'a' + , treeBelow = emptyCForest + } + , nonEmptyCursorNext = [] + } + } + in case forestCursorSwapNext start of + Nothing -> + expectationFailure "forestCursorSwapNext should not have failed." + Just r -> r `forestShouldBe` end + it "swaps the current node with the next node on the same level" pending + it "reverts forestCursorSwapPrev" $ + inverseFunctionsIfSucceedOnValid + (forestCursorSwapPrev @Rational @Rational) + (forestCursorSwapNext @Rational @Rational) + +deleteSpec :: Spec +deleteSpec = do + describe "forestCursorRemoveElemAndSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorRemoveElemAndSelectPrev @Rational) + it "works for this simple example" $ + forAllValid $ \fs -> + let simpleDeleteElemStart = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 1 :: Int + , treeBelow = closedForest [Node 2 fs] + } + , nonEmptyCursorNext = [] + } + } + in case forestCursorRemoveElemAndSelectPrev simpleDeleteElemStart of + Nothing -> pure () + Just Deleted -> + expectationFailure + "forestCursorRemoveElemAndSelectPrev should not have deleted the entire example forest." + Just (Updated _) -> + expectationFailure + "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 @Rational) + 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 + it "deletes the selected element and selects the next element" pending + describe "forestCursorRemoveElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorRemoveElem @Rational) + 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 + it "removes the selected element" pending + describe "forestCursorDeleteElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorDeleteElem @Rational) + 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 + it "deletes the selected element" pending + describe "forestCursorRemoveSubTreeAndSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorRemoveSubTreeAndSelectPrev @Rational) + it "removes the selected subtree and selects the previous tree" pending + describe "forestCursorDeleteSubTreeAndSelectNext" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorDeleteSubTreeAndSelectNext @Rational) + it "deletes the selected subtree and selects the next tree" pending + describe "forestCursorRemoveSubTree" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorRemoveSubTree @Rational) + it "removes the selected subtree" pending + describe "forestCursorDeleteSubTree" $ do + it "produces valid cursors" $ + producesValidsOnValids (forestCursorDeleteSubTree @Rational) + it "deletes the selected subtree" pending + +shiftingSpec :: Spec +shiftingSpec = do + describe "forestCursorPromoteElem" $ do + it "produces valids on valids" $ + producesValidsOnValids $ forestCursorPromoteElem @Rational + it "works on the example from the documentation" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { 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] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = + [ CNode 'a' $ + 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] + } + } + in case forestCursorPromoteElem start of + Nothing -> + expectationFailure + "forestCursorPromoteElem should not have failed." + 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 @Rational + it "works on the example from the documentation" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = + [CNode 'a' $ closedForest [Node 'b' []]] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'c' + , treeBelow = closedForest [Node 'd' []] + } + , nonEmptyCursorNext = [CNode 'e' emptyCForest] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { 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] + } + } + in case forestCursorDemoteElem start of + Nothing -> + expectationFailure + "forestCursorDemoteElem should not have failed." + 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 @Rational + it "works on the example from the documentation" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { 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] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = + [ CNode 'a' $ + 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] + } + } + in case forestCursorPromoteSubTree start of + Nothing -> + expectationFailure + "forestCursorPromoteSubTree should not have failed." + 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 @Rational + it "works on the example from the documentation" $ + let start = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = + [CNode 'a' $ closedForest [Node 'b' []]] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 'c' + , treeBelow = closedForest [Node 'd' []] + } + , nonEmptyCursorNext = [] + } + } + expected = + ForestCursor + { forestCursorListCursor = + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [CNode 'b' emptyCForest] + , treeAboveAbove = Nothing + , treeAboveNode = 'a' + , treeAboveRights = [] + } + , treeCurrent = 'c' + , treeBelow = closedForest [Node 'd' []] + } + , nonEmptyCursorNext = [] + } + } + in case forestCursorDemoteSubTree start of + Nothing -> + expectationFailure + "forestCursorDemoteSubTree should not have failed." + Just f -> f `forestShouldBe` expected + it "demotes the current subtree to the level of its children" pending + describe "forestCursorDemoteElemUnder" $ do + it "produces valids on valids" $ + producesValidsOnValids3 $ forestCursorDemoteElemUnder @Rational @Rational + 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 + it "demotes the current node to the level of its children" pending + describe "forestCursorDemoteSubTreeUnder" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ + forestCursorDemoteSubTreeUnder @Rational @Rational + 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 + 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 +isMovementM func = + forAllValid @(SFC.ForestCursor Int) $ \lec -> + case func lec of + Nothing -> pure () -- Fine + Just lec' -> + 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' + ] + +isMovement :: (forall a. SFC.ForestCursor a -> SFC.ForestCursor a) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildForestCursor (lec :: SFC.ForestCursor Int) `shouldBe` + rebuildForestCursor (func lec) + +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 + ] 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 @@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.List.NonEmptySpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -20,170 +20,165 @@ spec :: Spec spec = do - eqSpec @(NonEmptyCursor Int) - genValidSpec @(NonEmptyCursor Double) - shrinkValidSpec @(NonEmptyCursor Double) - describe "makeNonEmptyCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (makeNonEmptyCursor @Double) - describe "makeNonEmptyCursorWithSelection" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (makeNonEmptyCursorWithSelection @Double) - it - "is the inverse of rebuildNonEmptyCursor when using the current selection" $ - forAllValid $ \lec -> - makeNonEmptyCursorWithSelection - (nonEmptyCursorSelection @Double lec) - (rebuildNonEmptyCursor lec) `shouldBe` - Just lec - describe "singletonNonEmptyCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (singletonNonEmptyCursor @Double @Double) - describe "rebuildNonEmptyCursor" $ do - it "produces valid nonempty lists" $ - producesValidsOnValids (rebuildNonEmptyCursor @Double) - 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 - (makeNonEmptyCursorWithSelection @Int i) - rebuildNonEmptyCursor - describe "nonEmptyCursorElemL" $ - lensSpecOnValid (nonEmptyCursorElemL @Double @Double) - describe "nonEmptyCursorSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorSelectPrev @Double) - it "is a movement" $ isMovementM nonEmptyCursorSelectPrev - it "selects the previous element" pending - describe "nonEmptyCursorSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorSelectNext @Double) - it "is a movement" $ isMovementM nonEmptyCursorSelectNext - it "selects the next element" pending - describe "nonEmptyCursorSelectFirst" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorSelectFirst @Double) - it "is a movement" $ isMovement nonEmptyCursorSelectFirst - it "is idempotent" $ - idempotentOnValid (nonEmptyCursorSelectFirst @Double) - it "selects the first element" pending - describe "nonEmptyCursorSelectLast" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorSelectLast @Double) - it "is a movement" $ isMovement nonEmptyCursorSelectLast - it "is idempotent" $ - idempotentOnValid (nonEmptyCursorSelectLast @Double) - it "selects the last element" pending - describe "nonEmptyCursorSelection" $ do - it "produces valid ints" $ - producesValidsOnValids (nonEmptyCursorSelection @Double @Double) - it "returns the index of the currently selected element" pending - describe "nonEmptyCursorSelectIndex" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (nonEmptyCursorSelectIndex @Double) - it "is the identity function when given the current selection" $ - forAllValid $ \nec -> - nonEmptyCursorSelectIndex (nonEmptyCursorSelection nec) nec `shouldBe` - Just (nec :: NonEmptyCursor Double) - it "returns selects the element at the given index" pending - describe "nonEmptyCursorInsert" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids (nonEmptyCursorInsert @Double @Double d) - it "inserts a character before the cursor" pending - describe "nonEmptyCursorAppend" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids (nonEmptyCursorAppend @Double @Double d) - it "inserts a character after the cursor" pending - describe "nonEmptyCursorInsertAndSelect" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids (nonEmptyCursorInsertAndSelect @Double d) - it "inserts a character before the cursor and selects it" pending - describe "nonEmptyCursorAppendAndSelect" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids (nonEmptyCursorAppendAndSelect @Double d) - it "appends a character before the cursor and selects it" pending - describe "nonEmptyCursorInsertAtStart" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids - (nonEmptyCursorInsertAtStart @Double @Double d) - it "inserts a character at the start of the list" pending - describe "nonEmptyCursorAppendAtEnd" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids - (nonEmptyCursorAppendAtEnd @Double @Double d) - it "inserts a character at the end of the list" pending - describe "nonEmptyCursorInsertAtStartAndSelect" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids - (nonEmptyCursorInsertAtStartAndSelect @Double 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 @Double d) - it "appends a character at the end of the list and selects it" pending - describe "nonEmptyCursorRemoveElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorRemoveElem @Double) - it "removes an element" pending - describe "nonEmptyCursorDeleteElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (nonEmptyCursorDeleteElem @Double) - describe "nonEmptyCursorSearch" $ do - it "produces valid cursors when looking for an equal element" $ - forAllValid $ \a -> - producesValidsOnValids $ nonEmptyCursorSearch (== (a :: Double)) - 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 :: Double)) 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 :: Double)) nec of - Nothing -> - expectationFailure - "Should not have failed to find the element." - Just e -> nonEmptyCursorCurrent e `shouldBe` a - describe "nonEmptyCursorSelectOrAdd" $ do - it "produces valid cursors when looking for an equal element" $ - forAllValid $ \a -> - producesValidsOnValids $ - nonEmptyCursorSelectOrAdd (== a) (a :: Double) + eqSpec @(NonEmptyCursor Int) + genValidSpec @(NonEmptyCursor Rational) + shrinkValidSpec @(NonEmptyCursor Rational) + describe "makeNonEmptyCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (makeNonEmptyCursor @Rational) + describe "makeNonEmptyCursorWithSelection" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (makeNonEmptyCursorWithSelection @Rational) + it + "is the inverse of rebuildNonEmptyCursor when using the current selection" $ + forAllValid $ \lec -> + makeNonEmptyCursorWithSelection + (nonEmptyCursorSelection @Rational lec) + (rebuildNonEmptyCursor lec) `shouldBe` + Just lec + describe "singletonNonEmptyCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (singletonNonEmptyCursor @Rational @Rational) + describe "rebuildNonEmptyCursor" $ do + it "produces valid nonempty lists" $ + producesValidsOnValids (rebuildNonEmptyCursor @Rational) + 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 + (makeNonEmptyCursorWithSelection @Int i) + rebuildNonEmptyCursor + describe "nonEmptyCursorElemL" $ + lensSpecOnValid (nonEmptyCursorElemL @Rational @Rational) + describe "nonEmptyCursorSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorSelectPrev @Rational) + it "is a movement" $ isMovementM nonEmptyCursorSelectPrev + it "selects the previous element" pending + describe "nonEmptyCursorSelectNext" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorSelectNext @Rational) + it "is a movement" $ isMovementM nonEmptyCursorSelectNext + it "selects the next element" pending + describe "nonEmptyCursorSelectFirst" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorSelectFirst @Rational) + it "is a movement" $ isMovement nonEmptyCursorSelectFirst + it "is idempotent" $ idempotentOnValid (nonEmptyCursorSelectFirst @Rational) + it "selects the first element" pending + describe "nonEmptyCursorSelectLast" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorSelectLast @Rational) + it "is a movement" $ isMovement nonEmptyCursorSelectLast + it "is idempotent" $ idempotentOnValid (nonEmptyCursorSelectLast @Rational) + it "selects the last element" pending + describe "nonEmptyCursorSelection" $ do + it "produces valid ints" $ + producesValidsOnValids (nonEmptyCursorSelection @Rational @Rational) + it "returns the index of the currently selected element" pending + describe "nonEmptyCursorSelectIndex" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (nonEmptyCursorSelectIndex @Rational) + it "is the identity function when given the current selection" $ + forAllValid $ \nec -> + nonEmptyCursorSelectIndex (nonEmptyCursorSelection nec) nec `shouldBe` + Just (nec :: NonEmptyCursor Rational) + it "returns selects the element at the given index" pending + describe "nonEmptyCursorInsert" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids (nonEmptyCursorInsert @Rational @Rational d) + it "inserts a character before the cursor" pending + describe "nonEmptyCursorAppend" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids (nonEmptyCursorAppend @Rational @Rational d) + it "inserts a character after the cursor" pending + describe "nonEmptyCursorInsertAndSelect" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids (nonEmptyCursorInsertAndSelect @Rational d) + it "inserts a character before the cursor and selects it" pending + describe "nonEmptyCursorAppendAndSelect" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids (nonEmptyCursorAppendAndSelect @Rational d) + it "appends a character before the cursor and selects it" pending + describe "nonEmptyCursorInsertAtStart" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids + (nonEmptyCursorInsertAtStart @Rational @Rational d) + it "inserts a character at the start of the list" pending + describe "nonEmptyCursorAppendAtEnd" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids (nonEmptyCursorAppendAtEnd @Rational @Rational d) + it "inserts a character at the end of the list" pending + describe "nonEmptyCursorInsertAtStartAndSelect" $ do + it "produces valid cursors" $ + forAllValid $ \d -> + producesValidsOnValids + (nonEmptyCursorInsertAtStartAndSelect @Rational 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 @Rational d) + it "appends a character at the end of the list and selects it" pending + describe "nonEmptyCursorRemoveElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorRemoveElem @Rational) + it "removes an element" pending + describe "nonEmptyCursorDeleteElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (nonEmptyCursorDeleteElem @Rational) + describe "nonEmptyCursorSearch" $ do + it "produces valid cursors when looking for an equal element" $ + forAllValid $ \a -> + producesValidsOnValids $ nonEmptyCursorSearch (== (a :: Rational)) + 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 :: Rational)) 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 :: Rational)) nec of + Nothing -> + expectationFailure "Should not have failed to find the element." + Just e -> nonEmptyCursorCurrent e `shouldBe` a + describe "nonEmptyCursorSelectOrAdd" $ do + it "produces valid cursors when looking for an equal element" $ + forAllValid $ \a -> + producesValidsOnValids $ + nonEmptyCursorSelectOrAdd (== a) (a :: Rational) isMovementM :: - (forall a. NonEmptyCursor a -> Maybe (NonEmptyCursor a)) -> Property + (forall a. NonEmptyCursor a -> Maybe (NonEmptyCursor a)) -> Property isMovementM func = - forAllValid $ \lec -> - case func (lec :: NonEmptyCursor Double) of - Nothing -> pure () -- Fine - Just lec' -> - 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' - ] + forAllValid $ \lec -> + case func (lec :: NonEmptyCursor Rational) of + Nothing -> pure () -- Fine + Just lec' -> + 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' + ] isMovement :: (forall a. NonEmptyCursor a -> NonEmptyCursor a) -> Property isMovement func = - forAllValid $ \lec -> - rebuildNonEmptyCursor (lec :: NonEmptyCursor Double) `shouldBe` - rebuildNonEmptyCursor (func lec) + forAllValid $ \lec -> + rebuildNonEmptyCursor (lec :: NonEmptyCursor Rational) `shouldBe` + rebuildNonEmptyCursor (func lec) 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 @@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.Map.KeyValueSpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -17,37 +17,36 @@ spec :: Spec spec = do - describe "makeKeyValueCursorKey" $ - it "produces valid cursors" $ - producesValidsOnValids2 - (makeKeyValueCursorKey @Double @Rational @Double @Rational) - describe "makeKeyValueCursorValue" $ - it "produces valid cursors" $ - producesValidsOnValids2 - (makeKeyValueCursorValue @Double @Rational @Double @Rational) - describe "rebuildKeyValueCursor" $ - it "produces valid tuples" $ - producesValidsOnValids (rebuildKeyValueCursor @Double @Rational) - describe "keyValueCursorSelection" $ - it "produces valid selections" $ - producesValidsOnValids - (keyValueCursorSelection @Double @Rational @Double @Rational) - describe "keyValueCursorSelectKey" $ do - it "produces valid cursors" $ - producesValidsOnValids (keyValueCursorSelectKey @Double @Rational) - it "is a movement" $ isMovement keyValueCursorSelectKey - describe "keyValueCursorSelectValue" $ do - it "produces valid cursors" $ - producesValidsOnValids (keyValueCursorSelectValue @Double @Rational) - it "is a movement" $ isMovement keyValueCursorSelectValue - describe "keyValueCursorToggleSelected" $ do - it "produces valid cursors" $ - producesValidsOnValids - (keyValueCursorToggleSelected @Double @Rational) - it "is a movement" $ isMovement keyValueCursorToggleSelected + describe "makeKeyValueCursorKey" $ + it "produces valid cursors" $ + producesValidsOnValids2 + (makeKeyValueCursorKey @Rational @Rational @Rational @Rational) + describe "makeKeyValueCursorValue" $ + it "produces valid cursors" $ + producesValidsOnValids2 + (makeKeyValueCursorValue @Rational @Rational @Rational @Rational) + describe "rebuildKeyValueCursor" $ + it "produces valid tuples" $ + producesValidsOnValids (rebuildKeyValueCursor @Rational @Rational) + describe "keyValueCursorSelection" $ + it "produces valid selections" $ + producesValidsOnValids + (keyValueCursorSelection @Rational @Rational @Rational @Rational) + describe "keyValueCursorSelectKey" $ do + it "produces valid cursors" $ + producesValidsOnValids (keyValueCursorSelectKey @Rational @Rational) + it "is a movement" $ isMovement keyValueCursorSelectKey + describe "keyValueCursorSelectValue" $ do + it "produces valid cursors" $ + producesValidsOnValids (keyValueCursorSelectValue @Rational @Rational) + it "is a movement" $ isMovement keyValueCursorSelectValue + describe "keyValueCursorToggleSelected" $ do + it "produces valid cursors" $ + producesValidsOnValids (keyValueCursorToggleSelected @Rational @Rational) + it "is a movement" $ isMovement keyValueCursorToggleSelected isMovement :: (forall k v. KeyValueCursor k v -> KeyValueCursor k v) -> Property isMovement func = - forAllValid $ \lec -> - rebuildKeyValueCursor (lec :: KeyValueCursor Double Rational) `shouldBe` - rebuildKeyValueCursor (func lec) + forAllValid $ \lec -> + rebuildKeyValueCursor (lec :: KeyValueCursor Rational Rational) `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 @@ -3,8 +3,8 @@ {-# LANGUAGE RankNTypes #-} module Cursor.Simple.MapSpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -20,151 +20,149 @@ spec :: Spec spec = do - describe "makeMapCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (makeMapCursor @Double @Rational) - describe "makeMapCursorWithSelection" $ - it "produces valid cursors" $ - producesValidsOnValids2 (makeMapCursorWithSelection @Double @Rational) - describe "singletonMapCursorKey" $ - it "produces valid cursors" $ - producesValidsOnValids2 - (singletonMapCursorKey @Double @Rational @Double @Rational) - describe "singletonMapCursorValue" $ - it "produces valid cursors" $ - producesValidsOnValids2 - (singletonMapCursorValue @Double @Rational @Double @Rational) - describe "rebuildMapCursor" $ do - it "produces valid Nonempty lists" $ - producesValidsOnValids (rebuildMapCursor @Double @Rational) - it "is the inverse of makeMapCursor for integers" $ - inverseFunctions (makeMapCursor @Int @Int) rebuildMapCursor - describe "mapCursorNonEmptyCursorL" $ - lensSpecOnValid - (mapCursorNonEmptyCursorL @Double @Rational @Double @Rational) - describe "mapCursorElemL" $ - lensSpecOnValid (mapCursorElemL @Double @Rational @Double @Rational) - describe "mapCursorSelectKey" $ - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectKey @Double @Rational) - describe "mapCursorSelectValue" $ - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectValue @Double @Rational) - describe "mapCursorToggleSelected" $ - it "produces valid cursors" $ - producesValidsOnValids (mapCursorToggleSelected @Double @Rational) - describe "mapCursorSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectPrev @Double @Rational) - it "is a movement" $ isMovementM mapCursorSelectPrev - it "selects the previous element" pending - describe "mapCursorSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectNext @Double @Rational) - it "is a movement" $ isMovementM mapCursorSelectNext - it "selects the next element" pending - describe "mapCursorSelectFirst" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectFirst @Double @Rational) - it "is a movement" $ isMovement mapCursorSelectFirst - it "is idempotent" $ - idempotentOnValid (mapCursorSelectFirst @Double @Rational) - it "selects the first element" pending - describe "mapCursorSelectLast" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorSelectLast @Double @Rational) - it "is a movement" $ isMovement mapCursorSelectLast - it "is idempotent" $ - idempotentOnValid (mapCursorSelectLast @Double @Rational) - it "selects the last element" pending - describe "mapCursorSelection" $ do - it "produces valid ints" $ - producesValidsOnValids - (mapCursorSelection @Double @Rational @Double @Rational) - it "returns the index of the currently selected element" pending - describe "mapCursorSelectIndex" $ do - it "produces valid cursors" $ - producesValidsOnValids2 (mapCursorSelectIndex @Double @Rational) - it "is the identity function when given the current selection" $ - forAllValid $ \nec -> - mapCursorSelectIndex (mapCursorSelection nec) nec `shouldBe` - Just (nec :: MapCursor Double Rational) - it "returns selects the element at the given index" pending - describe "mapCursorInsert" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorInsert @Double @Rational @Double @Rational) - it "inserts a character before the cursor" pending - describe "mapCursorAppend" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorAppend @Double @Rational @Double @Rational) - it "inserts a character after the cursor" pending - describe "mapCursorInsertAndSelectKey" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorInsertAndSelectKey @Double @Rational) - describe "mapCursorAppendAndSelectKey" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorAppendAndSelectKey @Double @Rational) - describe "mapCursorInsertAndSelectValue" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorInsertAndSelectValue @Double @Rational) - describe "mapCursorAppendAndSelectValue" $ do - it "produces valid cursors" $ - producesValidsOnValids3 - (mapCursorAppendAndSelectValue @Double @Rational) - describe "mapCursorRemoveElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorRemoveElem @Double @Rational) - it "removes an element" pending - describe "mapCursorDeleteElem" $ do - it "produces valid cursors" $ - producesValidsOnValids (mapCursorDeleteElem @Double @Rational) - it "deletes an element" pending - describe "mapCursorSearch" $ do - it "produces valid cursors when looking for an equal pair" $ - forAllValid $ \(k, v) -> - producesValidsOnValids $ - mapCursorSearch @Double @Rational (\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 :: Double, v :: Rational) - describe "mapCursorSelectOrAdd" $ do - it "produces valid cursors when looking for an equal element" $ - forAllValid $ \(k, v) -> - producesValidsOnValids $ - mapCursorSelectOrAdd - (\k_ v_ -> k_ == k && v_ == v) - (makeKeyValueCursorKey (k :: Double) (v :: Rational)) + describe "makeMapCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (makeMapCursor @Rational @Rational) + describe "makeMapCursorWithSelection" $ + it "produces valid cursors" $ + producesValidsOnValids2 (makeMapCursorWithSelection @Rational @Rational) + describe "singletonMapCursorKey" $ + it "produces valid cursors" $ + producesValidsOnValids2 + (singletonMapCursorKey @Rational @Rational @Rational @Rational) + describe "singletonMapCursorValue" $ + it "produces valid cursors" $ + producesValidsOnValids2 + (singletonMapCursorValue @Rational @Rational @Rational @Rational) + describe "rebuildMapCursor" $ do + it "produces valid Nonempty lists" $ + producesValidsOnValids (rebuildMapCursor @Rational @Rational) + it "is the inverse of makeMapCursor for integers" $ + inverseFunctions (makeMapCursor @Int @Int) rebuildMapCursor + describe "mapCursorNonEmptyCursorL" $ + lensSpecOnValid + (mapCursorNonEmptyCursorL @Rational @Rational @Rational @Rational) + describe "mapCursorElemL" $ + lensSpecOnValid (mapCursorElemL @Rational @Rational @Rational @Rational) + describe "mapCursorSelectKey" $ + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectKey @Rational @Rational) + describe "mapCursorSelectValue" $ + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectValue @Rational @Rational) + describe "mapCursorToggleSelected" $ + it "produces valid cursors" $ + producesValidsOnValids (mapCursorToggleSelected @Rational @Rational) + describe "mapCursorSelectPrev" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectPrev @Rational @Rational) + it "is a movement" $ isMovementM mapCursorSelectPrev + it "selects the previous element" pending + describe "mapCursorSelectNext" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectNext @Rational @Rational) + it "is a movement" $ isMovementM mapCursorSelectNext + it "selects the next element" pending + describe "mapCursorSelectFirst" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectFirst @Rational @Rational) + it "is a movement" $ isMovement mapCursorSelectFirst + it "is idempotent" $ + idempotentOnValid (mapCursorSelectFirst @Rational @Rational) + it "selects the first element" pending + describe "mapCursorSelectLast" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorSelectLast @Rational @Rational) + it "is a movement" $ isMovement mapCursorSelectLast + it "is idempotent" $ + idempotentOnValid (mapCursorSelectLast @Rational @Rational) + it "selects the last element" pending + describe "mapCursorSelection" $ do + it "produces valid ints" $ + producesValidsOnValids + (mapCursorSelection @Rational @Rational @Rational @Rational) + it "returns the index of the currently selected element" pending + describe "mapCursorSelectIndex" $ do + it "produces valid cursors" $ + producesValidsOnValids2 (mapCursorSelectIndex @Rational @Rational) + it "is the identity function when given the current selection" $ + forAllValid $ \nec -> + mapCursorSelectIndex (mapCursorSelection nec) nec `shouldBe` + Just (nec :: MapCursor Rational Rational) + it "returns selects the element at the given index" pending + describe "mapCursorInsert" $ do + it "produces valid cursors" $ + producesValidsOnValids3 + (mapCursorInsert @Rational @Rational @Rational @Rational) + it "inserts a character before the cursor" pending + describe "mapCursorAppend" $ do + it "produces valid cursors" $ + producesValidsOnValids3 + (mapCursorAppend @Rational @Rational @Rational @Rational) + it "inserts a character after the cursor" pending + describe "mapCursorInsertAndSelectKey" $ do + it "produces valid cursors" $ + producesValidsOnValids3 (mapCursorInsertAndSelectKey @Rational @Rational) + describe "mapCursorAppendAndSelectKey" $ do + it "produces valid cursors" $ + producesValidsOnValids3 (mapCursorAppendAndSelectKey @Rational @Rational) + describe "mapCursorInsertAndSelectValue" $ do + it "produces valid cursors" $ + producesValidsOnValids3 + (mapCursorInsertAndSelectValue @Rational @Rational) + describe "mapCursorAppendAndSelectValue" $ do + it "produces valid cursors" $ + producesValidsOnValids3 + (mapCursorAppendAndSelectValue @Rational @Rational) + describe "mapCursorRemoveElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorRemoveElem @Rational @Rational) + it "removes an element" pending + describe "mapCursorDeleteElem" $ do + it "produces valid cursors" $ + producesValidsOnValids (mapCursorDeleteElem @Rational @Rational) + it "deletes an element" pending + describe "mapCursorSearch" $ do + it "produces valid cursors when looking for an equal pair" $ + forAllValid $ \(k, v) -> + producesValidsOnValids $ + mapCursorSearch @Rational @Rational (\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 :: Rational, v :: Rational) + describe "mapCursorSelectOrAdd" $ do + it "produces valid cursors when looking for an equal element" $ + forAllValid $ \(k, v) -> + producesValidsOnValids $ + mapCursorSelectOrAdd + (\k_ v_ -> k_ == k && v_ == v) + (makeKeyValueCursorKey (k :: Rational) (v :: Rational)) isMovementM :: (forall k v. MapCursor k v -> Maybe (MapCursor k v)) -> Property isMovementM func = - forAllValid $ \lec -> - case func (lec :: MapCursor Double Double) of - Nothing -> pure () -- Fine - Just lec' -> - 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' - ] + forAllValid $ \lec -> + case func (lec :: MapCursor Rational Rational) of + Nothing -> pure () -- Fine + Just lec' -> + 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' + ] isMovement :: (forall k v. MapCursor k v -> MapCursor k v) -> Property isMovement func = - forAllValid $ \lec -> - rebuildMapCursor (lec :: MapCursor Int Int) `shouldBe` - rebuildMapCursor (func lec) + forAllValid $ \lec -> + rebuildMapCursor (lec :: MapCursor Int Int) `shouldBe` + rebuildMapCursor (func lec) 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 @@ -5,9 +5,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Simple.Tree.BaseSpec - ( spec - ) where - + ( spec + ) where import Test.Hspec @@ -21,30 +20,29 @@ spec :: Spec spec = do - eqSpec @(STC.TreeCursor Int) - genValidSpec @(STC.TreeCursor Double) - describe "makeTreeCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (makeTreeCursor @Double) - describe "makeTreeCursorWithSelection" $ - it "produces valid cursors" $ - producesValidsOnValids2 (makeTreeCursorWithSelection @Double) - describe "singletonTreeCursor" $ - it "produces valid cursors" $ - producesValidsOnValids (singletonTreeCursor @Double) - describe "rebuildTreeCursor" $ do - it "produces valid trees" $ - producesValidsOnValids (rebuildTreeCursor @Double) - 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 - @Double - (treeCursorSelection tc) - (rebuildTreeCursor tc) of - Nothing -> - expectationFailure - "makeTreeCursorWithSelection should not have failed." - Just r -> r `treeShouldBe` tc + eqSpec @(STC.TreeCursor Int) + genValidSpec @(STC.TreeCursor Rational) + describe "makeTreeCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (makeTreeCursor @Rational) + describe "makeTreeCursorWithSelection" $ + it "produces valid cursors" $ + producesValidsOnValids2 (makeTreeCursorWithSelection @Rational) + describe "singletonTreeCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (singletonTreeCursor @Rational) + describe "rebuildTreeCursor" $ do + it "produces valid trees" $ + producesValidsOnValids (rebuildTreeCursor @Rational) + 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 + @Rational + (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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.CollapseSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -16,12 +16,20 @@ spec :: Spec spec = do - describe "treeCursorOpenCurrentForest" $ - it "produces valid cursors" $ - producesValidsOnValids $ treeCursorOpenCurrentForest @Double @Double - describe "treeCursorCloseCurrentForest" $ - it "produces valid cursors" $ - producesValidsOnValids $ treeCursorCloseCurrentForest @Double @Double - describe "treeCursorToggleCurrentForest" $ - it "produces valid cursors" $ - producesValidsOnValids $ treeCursorToggleCurrentForest @Double @Double + describe "treeCursorOpenCurrentForest" $ + it "produces valid cursors" $ + producesValidsOnValids $ treeCursorOpenCurrentForest @Rational @Rational + describe "treeCursorCloseCurrentForest" $ + it "produces valid cursors" $ + producesValidsOnValids $ treeCursorCloseCurrentForest @Rational @Rational + describe "treeCursorToggleCurrentForest" $ + it "produces valid cursors" $ + producesValidsOnValids $ treeCursorToggleCurrentForest @Rational @Rational + describe "treeCursorOpenCurrentForestRecursively" $ + it "produces valid cursors" $ + producesValidsOnValids $ + treeCursorOpenCurrentForestRecursively @Double @Double + describe "treeCursorToggleCurrentForestRecursively" $ + it "produces valid cursors" $ + producesValidsOnValids $ + treeCursorToggleCurrentForestRecursively @Double @Double 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.DeleteSpec - ( spec - ) where + ( spec + ) where import Data.Tree @@ -15,113 +15,102 @@ import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree - (CTree(..), TreeCursor(..), closedForest, openForest) +import Cursor.Tree (CTree(..), TreeCursor(..), closedForest, openForest) import Cursor.Types import Cursor.Simple.Tree.TestUtils spec :: Spec spec = do - describe "treeCursorDeleteSubTreeAndSelectPrevious" $ do - it "produces valids on valids" $ - producesValidsOnValids $ - treeCursorDeleteSubTreeAndSelectPrevious @Double - it "deletes the current subtree selects the previous subtree" pending - describe "treeCursorDeleteSubTreeAndSelectNext" $ do - it "produces valids on valids" $ - producesValidsOnValids $ - treeCursorDeleteSubTreeAndSelectNext @Double - it "deletes the current subtree selects the next subtree" pending - describe "treeCursorDeleteSubTreeAndSelectAbove" $ do - it "produces valids on valids" $ - producesValidsOnValids $ - treeCursorDeleteSubTreeAndSelectAbove @Double - it "deletes the current subtree selects the above node" pending - describe "treeCursorRemoveSubTree" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorRemoveSubTree @Double - it "removes the current subtree" pending - describe "treeCursorDeleteSubTree" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteSubTree @Double - it "deletes the current subtree" pending - describe "treeCursorDeleteElemAndSelectPrevious" $ do - it "produces valids on valids" $ - producesValidsOnValids $ - treeCursorDeleteElemAndSelectPrevious @Double - 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." - it - "deletes the current element and selects the previous element" - pending - describe "treeCursorDeleteElemAndSelectNext" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElemAndSelectNext @Double - 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 - it "deletes the current element and selects the next element" pending - describe "treeCursorDeleteElemAndSelectAbove" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElemAndSelectAbove @Double - it "works for this simple example" $ - forAllValid $ \fs -> - let simpleDeleteElemStart = - TreeCursor - { treeAbove = Nothing - , treeCurrent = 1 :: Int - , treeBelow = closedForest [Node 2 fs] - } - in case treeCursorDeleteElemAndSelectAbove simpleDeleteElemStart of - Nothing -> pure () - Just Deleted -> - expectationFailure - "treeCursorDeleteElemAndSelectAbove should not have deleted the entire example tree." - Just (Updated _) -> - expectationFailure - "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 @Double - it "removes the current element" pending - describe "treeCursorDeleteElem" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDeleteElem @Double - it "deletes the current element" pending + describe "treeCursorDeleteSubTreeAndSelectPrevious" $ do + it "produces valids on valids" $ + producesValidsOnValids $ + treeCursorDeleteSubTreeAndSelectPrevious @Rational + it "deletes the current subtree selects the previous subtree" pending + describe "treeCursorDeleteSubTreeAndSelectNext" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteSubTreeAndSelectNext @Rational + it "deletes the current subtree selects the next subtree" pending + describe "treeCursorDeleteSubTreeAndSelectAbove" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteSubTreeAndSelectAbove @Rational + it "deletes the current subtree selects the above node" pending + describe "treeCursorRemoveSubTree" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorRemoveSubTree @Rational + it "removes the current subtree" pending + describe "treeCursorDeleteSubTree" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteSubTree @Rational + it "deletes the current subtree" pending + describe "treeCursorDeleteElemAndSelectPrevious" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteElemAndSelectPrevious @Rational + 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." + it "deletes the current element and selects the previous element" pending + describe "treeCursorDeleteElemAndSelectNext" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteElemAndSelectNext @Rational + 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 + it "deletes the current element and selects the next element" pending + describe "treeCursorDeleteElemAndSelectAbove" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteElemAndSelectAbove @Rational + it "works for this simple example" $ + forAllValid $ \fs -> + let simpleDeleteElemStart = + TreeCursor + { treeAbove = Nothing + , treeCurrent = 1 :: Int + , treeBelow = closedForest [Node 2 fs] + } + in case treeCursorDeleteElemAndSelectAbove simpleDeleteElemStart of + Nothing -> pure () + Just Deleted -> + expectationFailure + "treeCursorDeleteElemAndSelectAbove should not have deleted the entire example tree." + Just (Updated _) -> + expectationFailure + "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 @Rational + it "removes the current element" pending + describe "treeCursorDeleteElem" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDeleteElem @Rational + 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.DemoteSpec - ( spec - ) where + ( spec + ) where import Data.Tree @@ -15,173 +15,168 @@ import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () -import Cursor.Tree - (TreeAbove(..), TreeCursor(..), closedForest, emptyCForest) +import Cursor.Tree (TreeAbove(..), TreeCursor(..), closedForest, emptyCForest) import Cursor.Simple.Tree.TestUtils spec :: Spec spec = do - functorSpec @DemoteResult - describe "treeCursorDemoteElem" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorDemoteElem @Double - it "Works on the example from the docs" $ - let promoteStart = - TreeCursor - { treeAbove = + functorSpec @DemoteResult + describe "treeCursorDemoteElem" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorDemoteElem @Rational + 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' []] + } + promoteEnd = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [node 'b' []] + , treeAboveAbove = Just - TreeAbove - { treeAboveLefts = [node 'a' [node 'b' []]] + TreeAbove + { treeAboveLefts = [] , treeAboveAbove = Nothing , treeAboveNode = 'p' , treeAboveRights = [node 'e' []] } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] - } - promoteEnd = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [node 'b' []] - , treeAboveAbove = - Just - TreeAbove - { 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 @Double - it "Works on the example from the docs" $ - let promoteStart = - TreeCursor - { treeAbove = + , 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 @Rational + 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' []] + } + promoteEnd = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [node 'b' []] + , treeAboveAbove = Just - TreeAbove - { treeAboveLefts = [node 'a' [node 'b' []]] + TreeAbove + { treeAboveLefts = [] , treeAboveAbove = Nothing , treeAboveNode = 'p' , treeAboveRights = [node 'e' []] } - , treeCurrent = 'c' - , treeBelow = closedForest [Node 'd' []] - } - promoteEnd = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [node 'b' []] - , treeAboveAbove = - Just - TreeAbove - { 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 @Double @Double - it "Works on the example from the docs" $ - 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" $ - producesValidsOnValids2 $ - treeCursorDemoteSubTreeUnder @Double @Double - 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 = + , 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 @Rational @Rational + it "Works on the example from the docs" $ + 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 + TreeAbove { treeAboveLefts = [] , treeAboveAbove = Nothing - , treeAboveNode = v - , treeAboveRights = [] + , treeAboveNode = 'p' + , treeAboveRights = [node b2 [node 'b' []]] } - , treeCurrent = 'a' - , treeBelow = closedForest [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" $ + producesValidsOnValids2 $ treeCursorDemoteSubTreeUnder @Rational @Rational + 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 = [] } - treeCursorDemoteSubTreeUnder v demoteStart `treeShouldBe` - demoteEnd - it - "demotes the current subtree to the level of its children, by adding a root" - pending + , treeCurrent = 'a' + , treeBelow = closedForest [Node 'b' []] + } + 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.InsertSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -16,35 +16,33 @@ spec :: Spec spec = do - describe "treeCursorInsert" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorInsert @Double @Double - it "inserts the element" pending - describe "treeCursorInsertAndSelect" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorInsertAndSelect @Double - it "inserts and select the element" pending - describe "treeCursorAppend" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorAppend @Double @Double - it "appends the element" pending - describe "treeCursorAppendAndSelect" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorAppendAndSelect @Double - it "appends and select the element" pending - describe "treeCursorAddChildAtPos" $ do - it "produces valid cursors " $ - producesValidsOnValids3 $ treeCursorAddChildAtPos @Double @Double - 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 @Double @Double - it - "adds a tree at the start of the children of the current node" - pending - describe "treeCursorAddChildAtEnd" $ do - it "produces valid cursors " $ - producesValidsOnValids2 $ treeCursorAddChildAtEnd @Double @Double - it "adds a tree at the end of the children of the current node" pending + describe "treeCursorInsert" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ treeCursorInsert @Rational @Rational + it "inserts the element" pending + describe "treeCursorInsertAndSelect" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ treeCursorInsertAndSelect @Rational + it "inserts and select the element" pending + describe "treeCursorAppend" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ treeCursorAppend @Rational @Rational + it "appends the element" pending + describe "treeCursorAppendAndSelect" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ treeCursorAppendAndSelect @Rational + it "appends and select the element" pending + describe "treeCursorAddChildAtPos" $ do + it "produces valid cursors " $ + producesValidsOnValids3 $ treeCursorAddChildAtPos @Rational @Rational + 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 @Rational @Rational + it "adds a tree at the start of the children of the current node" pending + describe "treeCursorAddChildAtEnd" $ do + it "produces valid cursors " $ + producesValidsOnValids2 $ treeCursorAddChildAtEnd @Rational @Rational + it "adds a tree at the end of the children of the current node" pending 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.MovementSpec - ( spec - ) where + ( spec + ) where import Control.Monad (unless) @@ -18,268 +18,258 @@ import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () import Cursor.Tree - (CTree(..), TreeAbove(..), TreeCursor(..), emptyCForest, - openForest) + ( CTree(..) + , TreeAbove(..) + , TreeCursor(..) + , emptyCForest + , openForest + ) import Cursor.Simple.Tree.TestUtils spec :: Spec spec = do - describe "treeCursorSelection" $ - it "produces valids on valids" $ - producesValidsOnValids (treeCursorSelection @Double @Double) - describe "treeCursorSelect" $ do - it "produces valids on valids" $ - producesValidsOnValids2 (treeCursorSelect @Double) - it "is identity with the current selection" $ - forAllValid $ \tc -> - let sel = treeCursorSelection tc - in case treeCursorSelect @Double 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" $ do - inverseFunctionsIfSucceedOnValid - (treeCursorSelectNextOnSameLevel @Double) - (treeCursorSelectPrevOnSameLevel @Double) - describe "treeCursorSelectNextOnSameLevel" $ do - testMovementM treeCursorSelectNextOnSameLevel - it "selects the next element" pending - it - "after treeCursorSelectPrevOnSameLevel is identity if they don't fail" $ do - inverseFunctionsIfSucceedOnValid - (treeCursorSelectPrevOnSameLevel @Double) - (treeCursorSelectNextOnSameLevel @Double) - describe "treeCursorSelectAbovePrev" $ do - testMovementM treeCursorSelectAbovePrev - it "Works for this classic example" $ + describe "treeCursorSelection" $ + it "produces valids on valids" $ + producesValidsOnValids (treeCursorSelection @Rational @Rational) + describe "treeCursorSelect" $ do + it "produces valids on valids" $ + producesValidsOnValids2 (treeCursorSelect @Rational) + it "is identity with the current selection" $ + forAllValid $ \tc -> + let sel = treeCursorSelection tc + in case treeCursorSelect @Rational 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" $ do + inverseFunctionsIfSucceedOnValid + (treeCursorSelectNextOnSameLevel @Rational) + (treeCursorSelectPrevOnSameLevel @Rational) + describe "treeCursorSelectNextOnSameLevel" $ do + testMovementM treeCursorSelectNextOnSameLevel + it "selects the next element" pending + it "after treeCursorSelectPrevOnSameLevel is identity if they don't fail" $ do + inverseFunctionsIfSucceedOnValid + (treeCursorSelectPrevOnSameLevel @Rational) + (treeCursorSelectNextOnSameLevel @Rational) + 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 - it "selects the previous element" pending - it "after treeCursorSelectAboveNext is identity if they don't fail" $ do - forAllValid $ \tc -> - case treeCursorSelectAboveNext @Double 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" $ + 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" $ do + forAllValid $ \tc -> + case treeCursorSelectAboveNext @Rational 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 - it "selects the next element" pending - it "after treeCursorSelectAbovePrev is identity if they don't fail" $ do - forAllValid $ \tc -> - case treeCursorSelectAbovePrev @Double 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" $ do - inverseFunctionsIfSucceedOnValid - (treeCursorSelectNext @Double) - (treeCursorSelectPrev @Double) - describe "treeCursorSelectNext" $ do - testMovementM treeCursorSelectNext - it "selects the next element" pending - it "after treeCursorSelectPrev is identity if they don't fail" $ do - inverseFunctionsIfSucceedOnValid - (treeCursorSelectPrev @Double) - (treeCursorSelectNext @Double) - describe "treeCursorSelectFirst" $ do - testMovement treeCursorSelectFirst - it "selects the first element" pending - it "is idempotent" $ idempotentOnValid $ treeCursorSelectFirst @Double - describe "treeCursorSelectLast" $ do - testMovement treeCursorSelectLast - it "selects the last element" pending - it "is idempotent" $ idempotentOnValid $ treeCursorSelectLast @Double - describe "treeCursorSelectAbove" $ do - testMovementM treeCursorSelectAbove - it "selects the element above" pending - it "after treeCursorSelectBelow is identity if they don't fail" $ do - inverseFunctionsIfSucceedOnValid - (treeCursorSelectBelowAtStart @Double) $ - treeCursorSelectAbove @Double - describe "treeCursorSelectBelowAtPos" $ do - it "produces valids on valids" $ - producesValidsOnValids2 $ treeCursorSelectBelowAtPos @Double - it "is a movement" $ - forAllValid $ \n -> isMovementM $ treeCursorSelectBelowAtPos n - it "selects the element n-th below" pending - describe "treeCursorSelectBelowAtStart" $ do - testMovementM treeCursorSelectBelowAtStart - it "selects the first child below" pending - describe "treeCursorSelectBelowAtEnd" $ do - testMovementM treeCursorSelectBelowAtEnd - it "selects the last child below" pending - describe "treeCursorSelectBelowAtStartRecursively" $ do - testMovementM treeCursorSelectBelowAtStartRecursively - it "selects the first child below, recursively" pending - describe "treeCursorSelectBelowAtEndRecursively" $ do - testMovementM treeCursorSelectBelowAtEndRecursively - it "selects the last child below, recursively" pending + 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" $ do + forAllValid $ \tc -> + case treeCursorSelectAbovePrev @Rational 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" $ do + inverseFunctionsIfSucceedOnValid + (treeCursorSelectNext @Rational) + (treeCursorSelectPrev @Rational) + describe "treeCursorSelectNext" $ do + testMovementM treeCursorSelectNext + it "selects the next element" pending + it "after treeCursorSelectPrev is identity if they don't fail" $ do + inverseFunctionsIfSucceedOnValid + (treeCursorSelectPrev @Rational) + (treeCursorSelectNext @Rational) + describe "treeCursorSelectFirst" $ do + testMovement treeCursorSelectFirst + it "selects the first element" pending + it "is idempotent" $ idempotentOnValid $ treeCursorSelectFirst @Rational + describe "treeCursorSelectLast" $ do + testMovement treeCursorSelectLast + it "selects the last element" pending + it "is idempotent" $ idempotentOnValid $ treeCursorSelectLast @Rational + describe "treeCursorSelectAbove" $ do + testMovementM treeCursorSelectAbove + it "selects the element above" pending + it "after treeCursorSelectBelow is identity if they don't fail" $ do + inverseFunctionsIfSucceedOnValid (treeCursorSelectBelowAtStart @Rational) $ + treeCursorSelectAbove @Rational + describe "treeCursorSelectBelowAtPos" $ do + it "produces valids on valids" $ + producesValidsOnValids2 $ treeCursorSelectBelowAtPos @Rational + it "is a movement" $ + forAllValid $ \n -> isMovementM $ treeCursorSelectBelowAtPos n + it "selects the element n-th below" pending + describe "treeCursorSelectBelowAtStart" $ do + testMovementM treeCursorSelectBelowAtStart + it "selects the first child below" pending + describe "treeCursorSelectBelowAtEnd" $ do + testMovementM treeCursorSelectBelowAtEnd + it "selects the last child below" pending + describe "treeCursorSelectBelowAtStartRecursively" $ do + testMovementM treeCursorSelectBelowAtStartRecursively + it "selects the first child below, recursively" pending + describe "treeCursorSelectBelowAtEndRecursively" $ do + testMovementM treeCursorSelectBelowAtEndRecursively + it "selects the last child below, recursively" pending 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.PromoteSpec - ( spec - ) where + ( spec + ) where import Data.Tree @@ -16,123 +16,124 @@ import Cursor.Simple.Tree hiding (TreeCursor) import Cursor.Simple.Tree.Gen () import Cursor.Tree - ( CTree(..), TreeAbove(..), TreeCursor(..), - closedForest, emptyCForest, openForest) + ( CTree(..) + , TreeAbove(..) + , TreeCursor(..) + , closedForest + , emptyCForest + , openForest + ) import Cursor.Simple.Tree.TestUtils spec :: Spec spec = do - functorSpec @PromoteElemResult - applicativeSpec @PromoteElemResult - monadSpec @PromoteElemResult - describe "treeCursorPromoteElem" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorPromoteElem @Double - it "Works on the example from the docs" $ - let promoteStart = - TreeCursor - { treeAbove = - Just - TreeAbove - { 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' []] - } - promoteEnd = - TreeCursor - { treeAbove = + functorSpec @PromoteElemResult + applicativeSpec @PromoteElemResult + monadSpec @PromoteElemResult + describe "treeCursorPromoteElem" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorPromoteElem @Rational + it "Works on the example from the docs" $ + let promoteStart = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [node 'b' [node 'c' []]] + , treeAboveAbove = Just - TreeAbove - { treeAboveLefts = - [ CNode 'a' $ - openForest - [ CNode 'b' $ - openForest - [ CNode 'c' emptyCForest - , CNode 'e' emptyCForest - ] - , CNode 'f' $ - closedForest [Node 'g' []] - ] - ] + TreeAbove + { treeAboveLefts = [] , treeAboveAbove = Nothing , treeAboveNode = 'p' - , treeAboveRights = [CNode 'h' emptyCForest] - } - , treeCurrent = 'd' - , treeBelow = emptyCForest - } - in case treeCursorPromoteElem promoteStart of - PromotedElem tc' -> tc' `treeShouldBe` promoteEnd - _ -> - expectationFailure - "treeCursorPromoteElem should not have failed" - it "promotes the current node to the level of its parent" pending - functorSpec @PromoteResult - applicativeSpec @PromoteResult - monadSpec @PromoteResult - describe "treeCursorPromoteSubTree" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorPromoteSubTree @Double - it "Works on the example from the docs" $ - let promoteStart = - TreeCursor - { treeAbove = - Just - TreeAbove - { 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' []]] + , treeAboveRights = [node 'h' []] } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] - } - promoteEnd = - TreeCursor - { treeAbove = + , treeAboveNode = 'a' + , treeAboveRights = [node 'f' [node 'g' []]] + } + , treeCurrent = 'd' + , treeBelow = closedForest [Node 'e' []] + } + promoteEnd = + TreeCursor + { treeAbove = + Just + 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 + } + in case treeCursorPromoteElem promoteStart of + PromotedElem tc' -> tc' `treeShouldBe` promoteEnd + _ -> + expectationFailure "treeCursorPromoteElem should not have failed" + it "promotes the current node to the level of its parent" pending + functorSpec @PromoteResult + applicativeSpec @PromoteResult + monadSpec @PromoteResult + describe "treeCursorPromoteSubTree" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorPromoteSubTree @Rational + it "Works on the example from the docs" $ + let promoteStart = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = + [CNode 'b' $ closedForest [Node 'c' []]] + , treeAboveAbove = Just - TreeAbove - { treeAboveLefts = - [ CNode 'a' $ - openForest - [ CNode 'b' $ - closedForest [Node 'c' []] - , CNode 'f' $ - closedForest [Node 'g' []] - ] - ] + TreeAbove + { treeAboveLefts = [] , treeAboveAbove = Nothing , treeAboveNode = 'p' - , treeAboveRights = [CNode 'h' $ closedForest []] + , treeAboveRights = [node 'h' []] } - , treeCurrent = 'd' - , treeBelow = closedForest [Node 'e' []] - } - in case treeCursorPromoteSubTree promoteStart of - Promoted tc' -> tc' `treeShouldBe` promoteEnd - _ -> - expectationFailure - "treeCursorPromoteSubTree should not have failed" - it "promotes the current subtree to the level of its parent" pending + , treeAboveNode = 'a' + , treeAboveRights = + [CNode 'f' $ closedForest [Node 'g' []]] + } + , treeCurrent = 'd' + , treeBelow = closedForest [Node 'e' []] + } + promoteEnd = + TreeCursor + { treeAbove = + Just + 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' []] + } + in case treeCursorPromoteSubTree promoteStart of + Promoted tc' -> tc' `treeShouldBe` promoteEnd + _ -> + expectationFailure + "treeCursorPromoteSubTree should not have failed" + it "promotes the current subtree to the level of its parent" pending 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 @@ -4,8 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Cursor.Simple.Tree.SwapSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -19,84 +19,80 @@ spec :: Spec spec = do - functorSpec @SwapResult - describe "treeCursorSwapPrev" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorSwapPrev @Double @Double - 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 - } - end = - TreeCursor - { treeAbove = - Just - TreeAbove - { 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 - (treeCursorSwapNext @Double @Double) - (treeCursorSwapPrev @Double @Double) - it "swaps the current node with the previous node" pending - describe "treeCursorSwapNext" $ do - it "produces valids on valids" $ - producesValidsOnValids $ treeCursorSwapNext @Double @Double - 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 - } - end = - TreeCursor - { treeAbove = - Just - TreeAbove - { 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 - (treeCursorSwapPrev @Double @Double) - (treeCursorSwapNext @Double @Double) - it "swaps the current node with the next node" pending + functorSpec @SwapResult + describe "treeCursorSwapPrev" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorSwapPrev @Rational @Rational + 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 + } + end = + TreeCursor + { treeAbove = + Just + TreeAbove + { 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 + (treeCursorSwapNext @Rational @Rational) + (treeCursorSwapPrev @Rational @Rational) + it "swaps the current node with the previous node" pending + describe "treeCursorSwapNext" $ do + it "produces valids on valids" $ + producesValidsOnValids $ treeCursorSwapNext @Rational @Rational + 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 + } + end = + TreeCursor + { treeAbove = + Just + TreeAbove + { 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 + (treeCursorSwapPrev @Rational @Rational) + (treeCursorSwapNext @Rational @Rational) + 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 @@ -22,57 +22,57 @@ testMovement :: (forall a. STC.TreeCursor a -> STC.TreeCursor a) -> Spec testMovement func = do - it "produces valids on valids" $ producesValidsOnValids $ func @Double - it "is a movement" $ isMovement func + it "produces valids on valids" $ producesValidsOnValids $ func @Rational + it "is a movement" $ isMovement func testMovementM :: - (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Spec + (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Spec testMovementM func = do - it "produces valids on valids" $ producesValidsOnValids $ func @Double - it "is a movement" $ isMovementM func + it "produces valids on valids" $ producesValidsOnValids $ func @Rational + it "is a movement" $ isMovementM func isMovementM :: - (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Property + (forall a. STC.TreeCursor a -> Maybe (STC.TreeCursor a)) -> Property isMovementM func = - forAllValid @(STC.TreeCursor Int) $ \lec -> - case func lec of - Nothing -> pure () -- Fine - Just lec' -> - 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') - ] + forAllValid @(STC.TreeCursor Int) $ \lec -> + case func lec of + Nothing -> pure () -- Fine + Just lec' -> + 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') + ] isMovement :: (forall a. STC.TreeCursor a -> STC.TreeCursor a) -> Property isMovement func = - forAllValid $ \lec -> - rebuildTreeCursor (lec :: STC.TreeCursor Int) `shouldBe` - rebuildTreeCursor (func lec) + forAllValid $ \lec -> + rebuildTreeCursor (lec :: STC.TreeCursor Int) `shouldBe` + rebuildTreeCursor (func lec) treeShouldBe :: - (Show a, Eq a) => STC.TreeCursor a -> STC.TreeCursor a -> Expectation + (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 - ] + unless (actual == expected) $ + expectationFailure $ + unlines + [ "The following should have been equal." + , "actual:" + , drawTreeCursor actual + , "expected:" + , drawTreeCursor expected + ] instance CanFail SwapResult where - hasFailed (Swapped _) = False - hasFailed _ = True - resultIfSucceeded (Swapped a) = Just a - resultIfSucceeded _ = Nothing + hasFailed (Swapped _) = False + hasFailed _ = True + resultIfSucceeded (Swapped a) = Just a + resultIfSucceeded _ = Nothing node :: a -> [CTree a] -> CTree a node a ts = CNode a $ closedForest $ map rebuildCTree ts diff --git a/test/Cursor/TextFieldSpec.hs b/test/Cursor/TextFieldSpec.hs --- a/test/Cursor/TextFieldSpec.hs +++ b/test/Cursor/TextFieldSpec.hs @@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.TextFieldSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -28,159 +28,152 @@ spec :: Spec spec = do - eqSpec @TextFieldCursor - genValidSpec @TextFieldCursor - describe "makeTextFieldCursor" $ - it "produces valid cursors" $ producesValidsOnValids makeTextFieldCursor - describe "makeTextFieldCursorWithSelection" $ do - it "produces valid cursors" $ - producesValidsOnValids3 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 - ] - describe "rebuildTextFieldCursorLines" $ do - it "produces valid lists" $ - producesValidsOnValids 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 - describe "rebuildTextFieldCursor" $ do - it "produces valid texts" $ - producesValidsOnValids rebuildTextFieldCursor - it "is the inverse of makeTextFieldCursor for integers" $ - inverseFunctionsOnValid makeTextFieldCursor rebuildTextFieldCursor - it - "is the inverse of makeTextFieldCursorWithSelection for integers, for any index" $ - forAllValid $ \x -> - forAllValid $ \y -> - inverseFunctionsIfFirstSucceedsOnValid - (makeTextFieldCursorWithSelection x y) - rebuildTextFieldCursor - describe "textFieldCursorSelection" $ - it "produces valid tuples" $ - producesValidsOnValids textFieldCursorSelection - describe "emptyTextFieldCursor" $ - it "is valid" $ shouldBeValid emptyTextFieldCursor - describe "nullTextFieldCursor" $ - it "produces valid" $ producesValidsOnValids nullTextFieldCursor - describe "textFieldCursorSelectPrevLine" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectPrevLine - it "is a movement" $ isMovementM textFieldCursorSelectPrevLine - it "selects the previous line" pending - describe "textFieldCursorSelectNextLine" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectNextLine - it "is a movement" $ isMovementM textFieldCursorSelectNextLine - it "selects the next line" pending - describe "textFieldCursorSelectFirstLine" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectFirstLine - it "is a movement" $ isMovement textFieldCursorSelectFirstLine - it "is idempotent" $ idempotentOnValid textFieldCursorSelectFirstLine - it "selects the first line" pending - describe "textFieldCursorSelectLastLine" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectLastLine - it "is a movement" $ isMovement textFieldCursorSelectLastLine - it "is idempotent" $ idempotentOnValid textFieldCursorSelectLastLine - it "selects the last line" pending - describe "textFieldCursorSelectPrevChar" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectPrevChar - it "selects the previous character on the current line" pending - describe "textFieldCursorSelectNextChar" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectNextChar - it "selects the previous character on the current line" pending - describe "textFieldCursorIndexOnLine" $ do - it "produces valid indices" $ - producesValidsOnValids textFieldCursorIndexOnLine - it "returns the index on the current line" pending - describe "textFieldCursorSelectIndexOnLine" $ do - it "produces valid cursors for any index" $ - producesValidsOnValids2 textFieldCursorSelectIndexOnLine - it "selects the given index on the current line" pending - describe "textFieldCursorInsertChar" $ do - it "produces valid cursors" $ - forAllValid $ \d -> - producesValidsOnValids (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) - it "inserts a character after the cursor on the currrent line" pending - describe "textFieldCursorInsertNewline" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorInsertNewline - it "inserts a new line" pending - describe "textFieldCursorAppendNewline" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorAppendNewline - describe "textFieldCursorRemove" $ do - it "produces valid cursors" $ - producesValidsOnValids 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 "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 "selects the start of the current line" pending - describe "textFieldCursorSelectEndOfLine" $ do - it "produces valid cursors" $ - producesValidsOnValids textFieldCursorSelectEndOfLine - it "selects the end of the current line" pending + eqSpecOnValid @TextFieldCursor + genValidSpec @TextFieldCursor + describe "makeTextFieldCursor" $ + it "produces valid cursors" $ producesValidsOnValids makeTextFieldCursor + describe "makeTextFieldCursorWithSelection" $ do + it "produces valid cursors" $ + producesValidsOnValids3 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 + ] + describe "rebuildTextFieldCursorLines" $ do + it "produces valid lists" $ + producesValidsOnValids 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 + describe "rebuildTextFieldCursor" $ do + it "produces valid texts" $ producesValidsOnValids rebuildTextFieldCursor + it "is the inverse of makeTextFieldCursor for integers" $ + inverseFunctionsOnValid makeTextFieldCursor rebuildTextFieldCursor + it + "is the inverse of makeTextFieldCursorWithSelection for integers, for any index" $ + forAllValid $ \x -> + forAllValid $ \y -> + inverseFunctionsIfFirstSucceedsOnValid + (makeTextFieldCursorWithSelection x y) + rebuildTextFieldCursor + describe "textFieldCursorSelection" $ + it "produces valid tuples" $ producesValidsOnValids textFieldCursorSelection + describe "emptyTextFieldCursor" $ + it "is valid" $ shouldBeValid emptyTextFieldCursor + describe "nullTextFieldCursor" $ + it "produces valid" $ producesValidsOnValids nullTextFieldCursor + describe "textFieldCursorSelectPrevLine" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectPrevLine + it "is a movement" $ isMovementM textFieldCursorSelectPrevLine + it "selects the previous line" pending + describe "textFieldCursorSelectNextLine" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectNextLine + it "is a movement" $ isMovementM textFieldCursorSelectNextLine + it "selects the next line" pending + describe "textFieldCursorSelectFirstLine" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectFirstLine + it "is a movement" $ isMovement textFieldCursorSelectFirstLine + it "is idempotent" $ idempotentOnValid textFieldCursorSelectFirstLine + it "selects the first line" pending + describe "textFieldCursorSelectLastLine" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectLastLine + it "is a movement" $ isMovement textFieldCursorSelectLastLine + it "is idempotent" $ idempotentOnValid textFieldCursorSelectLastLine + it "selects the last line" pending + describe "textFieldCursorSelectPrevChar" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectPrevChar + it "selects the previous character on the current line" pending + describe "textFieldCursorSelectNextChar" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectNextChar + it "selects the previous character on the current line" pending + describe "textFieldCursorIndexOnLine" $ do + it "produces valid indices" $ + producesValidsOnValids textFieldCursorIndexOnLine + it "returns the index on the current line" pending + describe "textFieldCursorSelectIndexOnLine" $ do + it "produces valid cursors for any index" $ + producesValidsOnValids2 textFieldCursorSelectIndexOnLine + it "selects the given index on the current line" pending + describe "textFieldCursorInsertChar" $ do + it "produces valid cursors" $ + forAllValid $ \d -> producesValidsOnValids (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) + it "inserts a character after the cursor on the currrent line" pending + describe "textFieldCursorInsertNewline" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorInsertNewline + it "inserts a new line" pending + describe "textFieldCursorAppendNewline" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorAppendNewline + describe "textFieldCursorRemove" $ do + it "produces valid cursors" $ producesValidsOnValids 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 "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 "selects the start of the current line" pending + describe "textFieldCursorSelectEndOfLine" $ do + it "produces valid cursors" $ + producesValidsOnValids textFieldCursorSelectEndOfLine + it "selects the end of the current line" pending isMovementM :: (TextFieldCursor -> Maybe TextFieldCursor) -> Property isMovementM func = - forAllValid $ \tfc -> - case func tfc of - Nothing -> pure () -- Fine - Just tfc' -> - 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' - ] + forAllValid $ \tfc -> + case func tfc of + Nothing -> pure () -- Fine + Just tfc' -> + 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' + ] isMovement :: (TextFieldCursor -> TextFieldCursor) -> Property isMovement func = - forAllValid $ \tfc -> - rebuildTextFieldCursor tfc `shouldBe` rebuildTextFieldCursor (func tfc) + forAllValid $ \tfc -> + rebuildTextFieldCursor tfc `shouldBe` rebuildTextFieldCursor (func tfc) diff --git a/test/Cursor/TextSpec.hs b/test/Cursor/TextSpec.hs --- a/test/Cursor/TextSpec.hs +++ b/test/Cursor/TextSpec.hs @@ -3,8 +3,8 @@ {-# LANGUAGE RankNTypes #-} module Cursor.TextSpec - ( spec - ) where + ( spec + ) where import Test.Hspec import Test.QuickCheck @@ -17,119 +17,113 @@ spec :: Spec spec = do - eqSpec @TextCursor - genValidSpec @TextCursor - describe "emptyTextCursor" $ it "is valid" $ shouldBeValid emptyTextCursor - describe "makeTextCursor" $ - it "produces valid list cursors" $ producesValidsOnValids makeTextCursor - describe "makeTextCursorWithSelection" $ - it "produces valid list cursors" $ - producesValidsOnValids2 makeTextCursorWithSelection - describe "rebuildTextCursor" $ do - it "produces valid lists" $ producesValidsOnValids rebuildTextCursor - it "is the inverse of makeTextCursor" $ - inverseFunctionsIfFirstSucceedsOnValid - 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 - describe "textCursorSelectPrev" $ do - it "produces valid cursors" $ - producesValidsOnValids textCursorSelectPrev - it "is a movement" $ isMovementM textCursorSelectPrev - it "selects the previous position" pending - describe "textCursorSelectNext" $ do - it "produces valid cursors" $ - producesValidsOnValids 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 "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 - describe "textCursorSelectStart" $ do - it "produces valid cursors" $ - producesValidsOnValids 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 "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 "returns the item before the position" pending - describe "textCursorNextChar" $ do - it "produces valid items" $ producesValidsOnValids textCursorNextChar - it "returns the item after the position" pending - describe "textCursorInsert" $ do - it "produces valids" $ - forAllValid $ \d -> producesValidsOnValids (textCursorInsert d) - it "inserts an item before the cursor" $ pending - describe "textCursorAppend" $ do - it "produces valids" $ - forAllValid $ \d -> producesValidsOnValids (textCursorAppend d) - it "inserts an item after the cursor" $ pending - describe "textCursorRemove" $ do - it "produces valids" $ validIfSucceedsOnValid textCursorRemove - it "removes an item before the cursor" $ pending - describe "textCursorDelete" $ do - it "produces valids" $ validIfSucceedsOnValid textCursorDelete - it "removes an item before the cursor" $ pending - describe "textCursorSplit" $ do - it "produces valids" $ producesValidsOnValids 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 - describe "textCursorCombine" $ do - it "produces valids" $ producesValidsOnValids2 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) + eqSpec @TextCursor + genValidSpec @TextCursor + describe "emptyTextCursor" $ it "is valid" $ shouldBeValid emptyTextCursor + describe "makeTextCursor" $ + it "produces valid list cursors" $ producesValidsOnValids makeTextCursor + describe "makeTextCursorWithSelection" $ + it "produces valid list cursors" $ + producesValidsOnValids2 makeTextCursorWithSelection + describe "rebuildTextCursor" $ do + it "produces valid lists" $ producesValidsOnValids rebuildTextCursor + it "is the inverse of makeTextCursor" $ + inverseFunctionsIfFirstSucceedsOnValid 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 + describe "textCursorSelectPrev" $ do + it "produces valid cursors" $ producesValidsOnValids textCursorSelectPrev + it "is a movement" $ isMovementM textCursorSelectPrev + it "selects the previous position" pending + describe "textCursorSelectNext" $ do + it "produces valid cursors" $ producesValidsOnValids 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 "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 + describe "textCursorSelectStart" $ do + it "produces valid cursors" $ producesValidsOnValids 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 "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 "returns the item before the position" pending + describe "textCursorNextChar" $ do + it "produces valid items" $ producesValidsOnValids textCursorNextChar + it "returns the item after the position" pending + describe "textCursorInsert" $ do + it "produces valids" $ + forAllValid $ \d -> producesValidsOnValids (textCursorInsert d) + it "inserts an item before the cursor" $ pending + describe "textCursorAppend" $ do + it "produces valids" $ + forAllValid $ \d -> producesValidsOnValids (textCursorAppend d) + it "inserts an item after the cursor" $ pending + describe "textCursorRemove" $ do + it "produces valids" $ validIfSucceedsOnValid textCursorRemove + it "removes an item before the cursor" $ pending + describe "textCursorDelete" $ do + it "produces valids" $ validIfSucceedsOnValid textCursorDelete + it "removes an item before the cursor" $ pending + describe "textCursorSplit" $ do + it "produces valids" $ producesValidsOnValids 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 + describe "textCursorCombine" $ do + it "produces valids" $ producesValidsOnValids2 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) isMovementM :: (TextCursor -> Maybe TextCursor) -> Property isMovementM func = - forAllValid $ \tc -> - case func tc of - Nothing -> pure () -- Fine - Just tc' -> - 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' - ] + forAllValid $ \tc -> + case func tc of + Nothing -> pure () -- Fine + Just tc' -> + 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' + ] isMovement :: (TextCursor -> TextCursor) -> Property isMovement func = - forAllValid $ \lec -> - rebuildTextCursor lec `shouldBe` rebuildTextCursor (func lec) + forAllValid $ \lec -> + rebuildTextCursor lec `shouldBe` rebuildTextCursor (func lec) 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 @@ -5,8 +5,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Cursor.Tree.TypesSpec - ( spec - ) where + ( spec + ) where import Test.Hspec @@ -18,42 +18,42 @@ spec :: Spec spec = do - eqSpec @TreeCursorSelection - genValidSpec @TreeCursorSelection - shrinkValidSpecWithLimit @TreeCursorSelection 100 - eqSpec @(SwapResult Int) - genValidSpec @(SwapResult Double) - shrinkValidSpecWithLimit @(SwapResult Int) 100 - eqSpec @(PromoteElemResult Int) - genValidSpec @(PromoteElemResult Double) - shrinkValidSpecWithLimit @(PromoteElemResult Int) 100 - eqSpec @(PromoteResult Int) - genValidSpec @(PromoteResult Double) - shrinkValidSpecWithLimit @(PromoteResult Int) 100 - eqSpec @(DemoteResult Int) - genValidSpec @(DemoteResult Double) - shrinkValidSpecWithLimit @(DemoteResult Int) 100 - eqSpec @(CTree Int) - genValidSpec @(CTree Double) - shrinkValidSpecWithLimit @(CTree Int) 100 - eqSpec @(CForest Int) - genValidSpec @(CForest Double) - shrinkValidSpecWithLimit @(CForest Int) 100 - eqSpec @(TreeAbove Int) - genValidSpec @(TreeAbove Double) - shrinkValidSpecWithLimit @(TreeAbove Int) 100 - describe "treeAboveLeftsL" $ lensSpecOnValid $ treeAboveLeftsL @Double - describe "treeAboveAboveL" $ lensSpecOnValid $ treeAboveAboveL @Double - describe "treeAboveNodeL" $ lensSpecOnValid $ treeAboveNodeL @Double - describe "treeAboveRightsL" $ lensSpecOnValid $ treeAboveRightsL @Double - eqSpec @(TreeCursor Int Word) - genValidSpec @(TreeCursor Float Double) - shrinkValidSpecWithLimit @(TreeCursor Word Int) 100 - describe "treeCursorAboveL" $ - lensSpecOnValid $ treeCursorAboveL @Float @Double - describe "treeCursorCurrentL" $ - lensSpecOnValid $ treeCursorCurrentL @Float @Double - describe "treeCursorBelowL" $ - lensSpecOnValid $ treeCursorBelowL @Float @Double - describe "treeCursorCurrentSubTreeL" $ - lensSpecOnValid $ treeCursorCurrentSubTreeL @Float @Double + eqSpec @TreeCursorSelection + genValidSpec @TreeCursorSelection + shrinkValidSpecWithLimit @TreeCursorSelection 10 + eqSpec @(SwapResult Int) + genValidSpec @(SwapResult Rational) + shrinkValidSpecWithLimit @(SwapResult Int) 10 + eqSpec @(PromoteElemResult Int) + genValidSpec @(PromoteElemResult Rational) + shrinkValidSpecWithLimit @(PromoteElemResult Int) 10 + eqSpec @(PromoteResult Int) + genValidSpec @(PromoteResult Rational) + shrinkValidSpecWithLimit @(PromoteResult Int) 10 + eqSpec @(DemoteResult Int) + genValidSpec @(DemoteResult Rational) + shrinkValidSpecWithLimit @(DemoteResult Int) 10 + eqSpec @(CTree Int) + genValidSpec @(CTree Rational) + shrinkValidSpecWithLimit @(CTree Int) 10 + eqSpec @(CForest Int) + genValidSpec @(CForest Rational) + shrinkValidSpecWithLimit @(CForest Int) 10 + eqSpec @(TreeAbove Int) + genValidSpec @(TreeAbove Rational) + shrinkValidSpecWithLimit @(TreeAbove Int) 10 + describe "treeAboveLeftsL" $ lensSpecOnValid $ treeAboveLeftsL @Rational + describe "treeAboveAboveL" $ lensSpecOnValid $ treeAboveAboveL @Rational + describe "treeAboveNodeL" $ lensSpecOnValid $ treeAboveNodeL @Rational + describe "treeAboveRightsL" $ lensSpecOnValid $ treeAboveRightsL @Rational + eqSpec @(TreeCursor Int Word) + genValidSpec @(TreeCursor Rational Rational) + shrinkValidSpecWithLimit @(TreeCursor Word Int) 10 + describe "treeCursorAboveL" $ + lensSpecOnValid $ treeCursorAboveL @Rational @Rational + describe "treeCursorCurrentL" $ + lensSpecOnValid $ treeCursorCurrentL @Rational @Rational + describe "treeCursorBelowL" $ + lensSpecOnValid $ treeCursorBelowL @Rational @Rational + describe "treeCursorCurrentSubTreeL" $ + lensSpecOnValid $ treeCursorCurrentSubTreeL @Rational @Rational