diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cursor-gen.cabal b/cursor-gen.cabal new file mode 100644 --- /dev/null +++ b/cursor-gen.cabal @@ -0,0 +1,92 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 58018e9f00ff2eb5016098f09115ecf1aad35674f8b0a9ca7a893c923064ab31 + +name: cursor-gen +version: 0.0.0.0 +synopsis: Generators for Purely Functional Cursors +description: Generators for Purely Functional Cursors for common data structures +category: Cursor +homepage: https://github.com/NorfairKing/cursor +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright: (c) 2018 Tom Sydney Kerckhove +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: + Cursor.Forest.Gen + Cursor.List.Gen + Cursor.List.NonEmpty.Gen + Cursor.Map.Gen + Cursor.Map.KeyValue.Gen + Cursor.Simple.Forest.Gen + Cursor.Simple.List.NonEmpty.Gen + Cursor.Simple.Map.Gen + Cursor.Simple.Map.KeyValue.Gen + Cursor.Simple.Tree.Gen + Cursor.Text.Gen + Cursor.TextField.Gen + Cursor.Tree.Gen + other-modules: + Paths_cursor_gen + hs-source-dirs: + src/ + ghc-options: -Wall + build-depends: + QuickCheck + , base <5 + , containers + , cursor + , genvalidity + , genvalidity-containers + , genvalidity-text + , text + default-language: Haskell2010 + +test-suite cursor-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Cursor.List.NonEmptySpec + Cursor.ListSpec + Cursor.Map.KeyValueSpec + Cursor.MapSpec + Cursor.Simple.ForestSpec + Cursor.Simple.List.NonEmptySpec + Cursor.Simple.Map.KeyValueSpec + Cursor.Simple.MapSpec + Cursor.Simple.Tree.BaseSpec + Cursor.Simple.Tree.CollapseSpec + Cursor.Simple.Tree.DeleteSpec + Cursor.Simple.Tree.DemoteSpec + Cursor.Simple.Tree.InsertSpec + Cursor.Simple.Tree.MovementSpec + Cursor.Simple.Tree.PromoteSpec + Cursor.Simple.Tree.SwapSpec + Cursor.Simple.Tree.TestUtils + Cursor.TextFieldSpec + 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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Forest/Gen.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Forest.Gen + ( + ) where + +import Data.GenValidity +import Data.GenValidity.Containers () + +import Cursor.Forest + +import Cursor.List.NonEmpty.Gen () +import Cursor.Tree.Gen () + +instance (GenUnchecked a, GenUnchecked b) => + GenUnchecked (ForestCursor a b) where + genUnchecked = ForestCursor <$> genUnchecked + shrinkUnchecked (ForestCursor ne) = ForestCursor <$> shrinkUnchecked ne + +instance (GenValid a, GenValid b) => GenValid (ForestCursor a b) where + genValid = ForestCursor <$> genValid + shrinkValid (ForestCursor ne) = ForestCursor <$> shrinkValid ne diff --git a/src/Cursor/List/Gen.hs b/src/Cursor/List/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/List/Gen.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.List.Gen + ( listCursorWithGen + , listCursorWithIndex0 + ) where + +import Test.QuickCheck + +import Cursor.List + +import Data.GenValidity + +instance GenUnchecked a => GenUnchecked (ListCursor a) where + genUnchecked = + sized $ \n -> do + (a, b) <- genSplit n + listCursorPrev <- resize a genUnchecked + listCursorNext <- resize b genUnchecked + pure ListCursor {..} + +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 {..} + +listCursorWithGen :: Gen a -> Gen (ListCursor a) +listCursorWithGen gen = ListCursor <$> genListOf gen <*> genListOf gen + +listCursorWithIndex0 :: Gen a -> Gen (ListCursor a) +listCursorWithIndex0 gen = ListCursor [] <$> genListOf gen diff --git a/src/Cursor/List/NonEmpty/Gen.hs b/src/Cursor/List/NonEmpty/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/List/NonEmpty/Gen.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.List.NonEmpty.Gen + ( nonEmptyElemOf + , nonEmptyWithIndex0 + , nonEmptyWith + ) where + +import Control.Monad + +import Data.GenValidity + +import Test.QuickCheck + +import qualified Data.List.NonEmpty as NE + +import Cursor.List.NonEmpty + +instance (GenUnchecked a, GenUnchecked b) => + GenUnchecked (NonEmptyCursor a b) where + genUnchecked = + 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 {..} + +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 {..} + +nonEmptyElemOf :: NonEmptyCursor a a -> Gen a +nonEmptyElemOf = elements . NE.toList . rebuildNonEmptyCursor id + +nonEmptyWithIndex0 :: Gen a -> Gen (NonEmptyCursor a a) +nonEmptyWithIndex0 g = NonEmptyCursor [] <$> g <*> genListOf g + +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 + ] + where + listWithA = do + l1 <- genListOf g + l2 <- genListOf g + pure $ l1 ++ [a] ++ l2 diff --git a/src/Cursor/Map/Gen.hs b/src/Cursor/Map/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Map/Gen.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Map.Gen + ( + ) where + +import Data.GenValidity +import Data.GenValidity.Containers () + +import Cursor.Map + +import Cursor.List.NonEmpty.Gen () +import Cursor.Map.KeyValue.Gen () + +instance (GenUnchecked kc, GenUnchecked vc, GenUnchecked k, GenUnchecked v) => + GenUnchecked (MapCursor kc vc k v) + +instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => + GenValid (MapCursor kc vc k v) where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering diff --git a/src/Cursor/Map/KeyValue/Gen.hs b/src/Cursor/Map/KeyValue/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Map/KeyValue/Gen.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Map.KeyValue.Gen + ( + ) where + +import Data.GenValidity + +import Cursor.Map.KeyValue + +instance (GenUnchecked kc, GenUnchecked vc, GenUnchecked k, GenUnchecked v) => + GenUnchecked (KeyValueCursor kc vc k v) + +instance (GenValid kc, GenValid vc, GenValid k, GenValid v) => + GenValid (KeyValueCursor kc vc k v) where + genValid = genValidStructurallyWithoutExtraChecking + shrinkValid = shrinkValidStructurallyWithoutExtraFiltering + +instance GenUnchecked KeyValueToggle + +instance GenValid KeyValueToggle diff --git a/src/Cursor/Simple/Forest/Gen.hs b/src/Cursor/Simple/Forest/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Forest/Gen.hs @@ -0,0 +1,5 @@ +module Cursor.Simple.Forest.Gen + ( + ) where + +import Cursor.Forest.Gen () diff --git a/src/Cursor/Simple/List/NonEmpty/Gen.hs b/src/Cursor/Simple/List/NonEmpty/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/List/NonEmpty/Gen.hs @@ -0,0 +1,19 @@ +module Cursor.Simple.List.NonEmpty.Gen + ( nonEmptyElemOf + , nonEmptyWithIndex0 + , nonEmptyWith + ) where + +import Test.QuickCheck + +import qualified Cursor.List.NonEmpty.Gen as NEC +import Cursor.Simple.List.NonEmpty + +nonEmptyElemOf :: NonEmptyCursor a -> Gen a +nonEmptyElemOf = NEC.nonEmptyElemOf + +nonEmptyWithIndex0 :: Gen a -> Gen (NonEmptyCursor a) +nonEmptyWithIndex0 = NEC.nonEmptyWithIndex0 + +nonEmptyWith :: a -> Gen a -> Gen (NonEmptyCursor a) +nonEmptyWith = NEC.nonEmptyWith diff --git a/src/Cursor/Simple/Map/Gen.hs b/src/Cursor/Simple/Map/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Map/Gen.hs @@ -0,0 +1,5 @@ +module Cursor.Simple.Map.Gen + ( + ) where + +import Cursor.Map.Gen () diff --git a/src/Cursor/Simple/Map/KeyValue/Gen.hs b/src/Cursor/Simple/Map/KeyValue/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Map/KeyValue/Gen.hs @@ -0,0 +1,5 @@ +module Cursor.Simple.Map.KeyValue.Gen + ( + ) where + +import Cursor.Map.KeyValue.Gen () diff --git a/src/Cursor/Simple/Tree/Gen.hs b/src/Cursor/Simple/Tree/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Tree/Gen.hs @@ -0,0 +1,5 @@ +module Cursor.Simple.Tree.Gen + ( + ) where + +import Cursor.Tree.Gen () diff --git a/src/Cursor/Text/Gen.hs b/src/Cursor/Text/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Text/Gen.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Text.Gen + ( textCursorWithGen + , textCursorWithIndex0 + ) where + +import Test.QuickCheck + +import Data.GenValidity +import Data.GenValidity.Text () + +import Cursor.Text + +import Cursor.List.Gen + +instance GenUnchecked TextCursor + +instance GenValid TextCursor where + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally + +textCursorWithGen :: Gen Char -> Gen TextCursor +textCursorWithGen gen = TextCursor <$> listCursorWithGen gen + +textCursorWithIndex0 :: Gen Char -> Gen TextCursor +textCursorWithIndex0 gen = TextCursor <$> listCursorWithIndex0 gen diff --git a/src/Cursor/TextField/Gen.hs b/src/Cursor/TextField/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/TextField/Gen.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.TextField.Gen where + +import qualified Data.Text as T + +import Data.GenValidity + +import Test.QuickCheck + +import Cursor.List.NonEmpty +import Cursor.TextField + +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 diff --git a/src/Cursor/Tree/Gen.hs b/src/Cursor/Tree/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Gen.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Tree.Gen + ( + ) where + +import qualified Data.List.NonEmpty as NE +import Data.Maybe + +import Data.GenValidity +import Data.GenValidity.Containers () + +import Test.QuickCheck + +import Cursor.Tree + +instance GenUnchecked TreeCursorSelection + +instance GenValid TreeCursorSelection where + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally + +instance GenUnchecked a => GenUnchecked (SwapResult a) + +instance GenValid a => GenValid (SwapResult a) where + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally + +instance GenUnchecked a => GenUnchecked (PromoteElemResult a) + +instance GenValid a => GenValid (PromoteElemResult a) where + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally + +instance GenUnchecked a => GenUnchecked (PromoteResult a) + +instance GenValid a => GenValid (PromoteResult a) where + genValid = genValidStructurally + shrinkValid = shrinkValidStructurally + +instance GenUnchecked a => GenUnchecked (DemoteResult a) + +instance GenValid a => GenValid (DemoteResult a) where + 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)] + +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)] + +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) + +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) + +instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (TreeCursor a b) where + genUnchecked = + sized $ \n -> do + s <- upTo n + (a, b, c, d) <- genSplit4 s + treeAbove <- resize (a + b) genUnchecked + treeCurrent <- resize c genUnchecked + treeBelow <- resize d genUnchecked + pure TreeCursor {..} + shrinkUnchecked tc = + let opts = + catMaybes + [ do ta <- treeAbove tc + pure $ tc {treeAbove = treeAboveAbove ta} + ] + in opts ++ genericShrinkUnchecked tc + +instance (GenValid a, GenValid b) => GenValid (TreeCursor a b) where + genValid = + sized $ \n -> do + 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 {..} + +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 diff --git a/test/Cursor/List/NonEmptySpec.hs b/test/Cursor/List/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/List/NonEmptySpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.List.NonEmptySpec + ( spec + ) where + +import Test.Hspec +import Test.Validity + +import qualified Data.List.NonEmpty as NE + +import Cursor.List.NonEmpty + +spec :: Spec +spec = do + describe "nonemptyPrepend" $ + it "is equivalent to regular prepend" $ + equivalentWhenFirstSucceeds + (\(ls1, ls2) -> + (NE.toList . nonemptyPrepend ls1) <$> NE.nonEmpty ls2) + (uncurry (++) :: ([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 new file mode 100644 --- /dev/null +++ b/test/Cursor/ListSpec.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} + +module Cursor.ListSpec + ( spec + ) where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity + +import Control.Monad + +import Cursor.List +import Cursor.List.Gen () + +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) + +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' + ] + +isMovement :: (forall a. ListCursor a -> ListCursor a) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildListCursor (lec :: ListCursor Int) `shouldBe` + rebuildListCursor (func lec) diff --git a/test/Cursor/Map/KeyValueSpec.hs b/test/Cursor/Map/KeyValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Map/KeyValueSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeApplications #-} + +module Cursor.Map.KeyValueSpec + ( spec + ) where + +import Test.Hspec + +import Test.Validity + +import Cursor.Map.KeyValue +import Cursor.Map.KeyValue.Gen () + +spec :: Spec +spec = do + 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/MapSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} + +module Cursor.MapSpec + ( spec + ) where + +import Test.Hspec +import Test.Validity + +import Cursor.Map +import Cursor.Map.Gen () + +spec :: Spec +spec = do + 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/ForestSpec.hs @@ -0,0 +1,1014 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# 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 + ] diff --git a/test/Cursor/Simple/List/NonEmptySpec.hs b/test/Cursor/Simple/List/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/List/NonEmptySpec.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.Simple.List.NonEmptySpec + ( spec + ) where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Test.Validity.Optics + +import Control.Monad + +import Cursor.Simple.List.NonEmpty +import Cursor.Simple.List.NonEmpty.Gen + +spec :: Spec +spec = do + eqSpec @(NonEmptyCursor 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) + +isMovementM :: + (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' + ] + +isMovement :: (forall a. NonEmptyCursor a -> NonEmptyCursor a) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildNonEmptyCursor (lec :: NonEmptyCursor Double) `shouldBe` + rebuildNonEmptyCursor (func lec) diff --git a/test/Cursor/Simple/Map/KeyValueSpec.hs b/test/Cursor/Simple/Map/KeyValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Map/KeyValueSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.Simple.Map.KeyValueSpec + ( spec + ) where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity + +import Cursor.Simple.Map.KeyValue +import Cursor.Simple.Map.KeyValue.Gen () + +spec :: Spec +spec = do + describe "makeKeyValueCursorKey" $ + it "produces valid cursors" $ + producesValidsOnValids2 + (makeKeyValueCursorKey @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 + +isMovement :: (forall k v. KeyValueCursor k v -> KeyValueCursor k v) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildKeyValueCursor (lec :: KeyValueCursor Double Rational) `shouldBe` + rebuildKeyValueCursor (func lec) diff --git a/test/Cursor/Simple/MapSpec.hs b/test/Cursor/Simple/MapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/MapSpec.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} + +module Cursor.Simple.MapSpec + ( spec + ) where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Test.Validity.Optics + +import Lens.Micro + +import Control.Monad + +import Cursor.Simple.Map +import Cursor.Simple.Map.Gen () + +spec :: Spec +spec = do + describe "makeMapCursor" $ + it "produces valid cursors" $ + producesValidsOnValids (makeMapCursor @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)) + +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' + ] + +isMovement :: (forall k v. MapCursor k v -> MapCursor k v) -> Property +isMovement func = + 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/BaseSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Simple.Tree.BaseSpec + ( spec + ) where + + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import qualified Cursor.Simple.Tree as STC (TreeCursor) +import Cursor.Simple.Tree.Gen () + +import Cursor.Simple.Tree.TestUtils + +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 diff --git a/test/Cursor/Simple/Tree/CollapseSpec.hs b/test/Cursor/Simple/Tree/CollapseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/CollapseSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.CollapseSpec + ( spec + ) where + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () + +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 diff --git a/test/Cursor/Simple/Tree/DeleteSpec.hs b/test/Cursor/Simple/Tree/DeleteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/DeleteSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.DeleteSpec + ( spec + ) where + +import Data.Tree + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () +import Cursor.Tree + (CTree(..), TreeCursor(..), closedForest, openForest) +import Cursor.Types + +import Cursor.Simple.Tree.TestUtils + +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 diff --git a/test/Cursor/Simple/Tree/DemoteSpec.hs b/test/Cursor/Simple/Tree/DemoteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/DemoteSpec.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.DemoteSpec + ( spec + ) where + +import Data.Tree + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () +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 = + 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 = [] + , 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 = + 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 = [] + , 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 = + Just + TreeAbove + { treeAboveLefts = [] + , treeAboveAbove = Nothing + , treeAboveNode = v + , treeAboveRights = [] + } + , 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/InsertSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.InsertSpec + ( spec + ) where + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () + +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 diff --git a/test/Cursor/Simple/Tree/MovementSpec.hs b/test/Cursor/Simple/Tree/MovementSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/MovementSpec.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.MovementSpec + ( spec + ) where + +import Control.Monad (unless) + +import Text.Show.Pretty + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () +import Cursor.Tree + (CTree(..), TreeAbove(..), TreeCursor(..), emptyCForest, + openForest) + +import Cursor.Simple.Tree.TestUtils + +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" $ + -- > 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" $ + -- > 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 diff --git a/test/Cursor/Simple/Tree/PromoteSpec.hs b/test/Cursor/Simple/Tree/PromoteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/PromoteSpec.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.PromoteSpec + ( spec + ) where + +import Data.Tree + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () +import Cursor.Tree + ( 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 = + 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 @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' []]] + } + , 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/SwapSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cursor.Simple.Tree.SwapSpec + ( spec + ) where + +import Test.Hspec + +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import Cursor.Simple.Tree.Gen () +import Cursor.Tree (TreeAbove(..), TreeCursor(..), emptyCForest) + +import Cursor.Simple.Tree.TestUtils + +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 diff --git a/test/Cursor/Simple/Tree/TestUtils.hs b/test/Cursor/Simple/Tree/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Simple/Tree/TestUtils.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Simple.Tree.TestUtils where + +import Data.Tree + +import Control.Monad (unless) + +import Test.Hspec + +import Test.QuickCheck +import Test.Validity + +import Cursor.Simple.Tree hiding (TreeCursor) +import qualified Cursor.Simple.Tree as STC (TreeCursor) +import Cursor.Simple.Tree.Gen () +import Cursor.Tree (CTree(..), closedForest) + +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 + +testMovementM :: + (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 + +isMovementM :: + (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') + ] + +isMovement :: (forall a. STC.TreeCursor a -> STC.TreeCursor a) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildTreeCursor (lec :: STC.TreeCursor Int) `shouldBe` + rebuildTreeCursor (func lec) + +treeShouldBe :: + (Show a, Eq a) => STC.TreeCursor a -> STC.TreeCursor a -> Expectation +treeShouldBe actual expected = + unless (actual == expected) $ + expectationFailure $ + unlines + [ "The following should have been equal." + , "actual:" + , drawTreeCursor actual + , "expected:" + , drawTreeCursor expected + ] + +instance CanFail SwapResult where + 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 new file mode 100644 --- /dev/null +++ b/test/Cursor/TextFieldSpec.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.TextFieldSpec + ( spec + ) where + +import Test.Hspec + +import Test.QuickCheck +import Test.Validity + +-- import Test.Validity.Optics +import Text.Show.Pretty (ppShow) + +import qualified Data.Text as T + +import qualified Data.List.NonEmpty as NE + +import Control.Monad + +import Cursor.TextField +import Cursor.TextField.Gen () +import Cursor.Types + +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 + +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' + ] + +isMovement :: (TextFieldCursor -> TextFieldCursor) -> Property +isMovement func = + forAllValid $ \tfc -> + rebuildTextFieldCursor tfc `shouldBe` rebuildTextFieldCursor (func tfc) diff --git a/test/Cursor/TextSpec.hs b/test/Cursor/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/TextSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} + +module Cursor.TextSpec + ( spec + ) where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity + +import Control.Monad + +import Cursor.Text +import Cursor.Text.Gen () + +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) + +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' + ] + +isMovement :: (TextCursor -> TextCursor) -> Property +isMovement func = + forAllValid $ \lec -> + rebuildTextCursor lec `shouldBe` rebuildTextCursor (func lec) diff --git a/test/Cursor/Tree/TypesSpec.hs b/test/Cursor/Tree/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cursor/Tree/TypesSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cursor.Tree.TypesSpec + ( spec + ) where + +import Test.Hspec + +import Test.Validity +import Test.Validity.Optics + +import Cursor.Tree +import Cursor.Tree.Gen () + +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}