diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ # Changelog -## [Unreleased] +## [0.3.1.0] - 2021-11-23 + +### Added + +- `listCursorPrevUntil` +- `listCursorNextUntil` +- `listCursorInsertList` +- `listCursorAppendList` ## [0.3.0.0] - 2020-02-14 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018 Tom Sydney Kerckhove +Copyright (c) 2018-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/cursor.cabal b/cursor.cabal --- a/cursor.cabal +++ b/cursor.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: eb21207b1fb477978ab67b054e6cadf6a1d4b7ccfc60a7dea2f0e206586eb33f +-- hash: 295467a341ff6e00d4d214636b3656ec0c9a1e9edbd8a56c8801ff54b64d7445 name: cursor -version: 0.3.0.0 +version: 0.3.1.0 synopsis: Purely Functional Cursors description: Purely Functional Cursors for common data structures . @@ -16,7 +16,7 @@ homepage: https://github.com/NorfairKing/cursor author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2018 Tom Sydney Kerckhove +copyright: Copyright: (c) 2018-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple diff --git a/src/Cursor/Forest.hs b/src/Cursor/Forest.hs --- a/src/Cursor/Forest.hs +++ b/src/Cursor/Forest.hs @@ -3,109 +3,126 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Forest - ( ForestCursor(..) - , makeForestCursor - , rebuildForestCursor - , drawForestCursor - , mapForestCursor - , forestCursorListCursorL - , forestCursorSelectedTreeL - , forestCursorSelectPrevTreeCursor - , forestCursorSelectNextTreeCursor - , forestCursorSelectFirstTreeCursor - , forestCursorSelectLastTreeCursor - , forestCursorSelectPrev - , forestCursorSelectNext - , forestCursorSelectPrevOnSameLevel - , forestCursorSelectNextOnSameLevel - , forestCursorSelectFirst - , forestCursorSelectLast - , forestCursorSelectAbove - , forestCursorSelectBelowAtPos - , forestCursorSelectBelowAtStart - , forestCursorSelectBelowAtEnd - , forestCursorSelection - , forestCursorSelectIndex - , forestCursorOpenCurrentForest - , forestCursorCloseCurrentForest - , forestCursorToggleCurrentForest - , forestCursorOpenCurrentForestRecursively - , forestCursorToggleCurrentForestRecursively - , forestCursorInsertEntireTree - , forestCursorAppendEntireTree - , forestCursorInsertAndSelectTreeCursor - , forestCursorAppendAndSelectTreeCursor - , forestCursorInsertTree - , forestCursorAppendTree - , forestCursorInsertAndSelectTree - , forestCursorAppendAndSelectTree - , forestCursorInsert - , forestCursorAppend - , forestCursorInsertAndSelect - , forestCursorAppendAndSelect - , forestCursorAddChildTreeToNodeAtPos - , forestCursorAddChildTreeToNodeAtStart - , forestCursorAddChildTreeToNodeAtEnd - , forestCursorAddChildToNodeAtPos - , forestCursorAddChildToNodeAtStart - , forestCursorAddChildToNodeAtEnd - , forestCursorRemoveElemAndSelectPrev - , forestCursorDeleteElemAndSelectNext - , forestCursorRemoveElem - , forestCursorDeleteElem - , forestCursorRemoveSubTreeAndSelectPrev - , forestCursorDeleteSubTreeAndSelectNext - , forestCursorRemoveSubTree - , forestCursorDeleteSubTree - , forestCursorAddRoot - , forestCursorSwapPrev - , forestCursorSwapNext - , forestCursorPromoteElem - , forestCursorPromoteSubTree - , forestCursorDemoteElem - , forestCursorDemoteSubTree - , forestCursorDemoteElemUnder - , forestCursorDemoteSubTreeUnder - , CTree(..) - , makeCTree - , cTree - , rebuildCTree - , CForest(..) - , makeCForest - , cForest - , rebuildCForest - , traverseForestCursor - , foldForestCursor - ) where - -import GHC.Generics (Generic) - -import Data.Validity -import Data.Validity.Tree () - -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe -import Data.Tree + ( ForestCursor (..), + singletonForestCursor, + makeForestCursor, + rebuildForestCursor, + drawForestCursor, + mapForestCursor, + forestCursorListCursorL, + forestCursorSelectedTreeL, + forestCursorSelectPrevTreeCursor, + forestCursorSelectNextTreeCursor, + forestCursorSelectFirstTreeCursor, + forestCursorSelectLastTreeCursor, + forestCursorSelectPrev, + forestCursorSelectNext, + forestCursorSelectPrevOnSameLevel, + forestCursorSelectNextOnSameLevel, + forestCursorSelectFirst, + forestCursorSelectLast, + forestCursorSelectFirstOnSameLevel, + forestCursorSelectLastOnSameLevel, + forestCursorSelectAbove, + forestCursorSelectBelowAtPos, + forestCursorSelectBelowAtStart, + forestCursorSelectBelowAtEnd, + forestCursorSelection, + forestCursorSelectIndex, + forestCursorOpenCurrentForest, + forestCursorCloseCurrentForest, + forestCursorToggleCurrentForest, + forestCursorOpenCurrentForestRecursively, + forestCursorToggleCurrentForestRecursively, + forestCursorInsertEntireTree, + forestCursorAppendEntireTree, + forestCursorInsertAndSelectTreeCursor, + forestCursorAppendAndSelectTreeCursor, + forestCursorInsertTree, + forestCursorAppendTree, + forestCursorInsertAndSelectTree, + forestCursorAppendAndSelectTree, + forestCursorInsert, + forestCursorAppend, + forestCursorInsertAndSelect, + forestCursorAppendAndSelect, + forestCursorInsertNodeSingleAndSelect, + forestCursorAppendNodeSingleAndSelect, + forestCursorInsertNodeAndSelect, + forestCursorAppendNodeAndSelect, + forestCursorAddChildTreeToNodeAtPos, + forestCursorAddChildTreeToNodeAtStart, + forestCursorAddChildTreeToNodeAtEnd, + forestCursorAddChildToNodeAtPos, + forestCursorAddChildToNodeAtStart, + forestCursorAddChildToNodeAtEnd, + forestCursorAddChildTreeToNodeAtPosAndSelect, + forestCursorAddChildTreeToNodeAtStartAndSelect, + forestCursorAddChildTreeToNodeAtEndAndSelect, + forestCursorAddChildToNodeAtPosAndSelect, + forestCursorAddChildToNodeAtStartAndSelect, + forestCursorAddChildToNodeAtEndAndSelect, + forestCursorAddChildNodeSingleToNodeAtPosAndSelect, + forestCursorAddChildNodeSingleToNodeAtStartAndSelect, + forestCursorAddChildNodeSingleToNodeAtEndAndSelect, + forestCursorAddChildNodeToNodeAtPosAndSelect, + forestCursorAddChildNodeToNodeAtStartAndSelect, + forestCursorAddChildNodeToNodeAtEndAndSelect, + forestCursorRemoveElemAndSelectPrev, + forestCursorDeleteElemAndSelectNext, + forestCursorRemoveElem, + forestCursorDeleteElem, + forestCursorRemoveSubTreeAndSelectPrev, + forestCursorDeleteSubTreeAndSelectNext, + forestCursorRemoveSubTree, + forestCursorDeleteSubTree, + forestCursorAddRoot, + forestCursorSwapPrev, + forestCursorSwapNext, + forestCursorPromoteElem, + forestCursorPromoteSubTree, + forestCursorDemoteElem, + forestCursorDemoteSubTree, + forestCursorDemoteElemUnder, + forestCursorDemoteSubTreeUnder, + CTree (..), + makeCTree, + cTree, + rebuildCTree, + CForest (..), + makeCForest, + cForest, + rebuildCForest, + traverseForestCursor, + foldForestCursor, + ) +where import Control.Applicative import Control.DeepSeq - -import Lens.Micro - import Cursor.List.NonEmpty import Cursor.Tree import Cursor.Types +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe +import Data.Tree +import Data.Validity +import Data.Validity.Tree () +import GHC.Generics (Generic) +import Lens.Micro -newtype ForestCursor a b = - ForestCursor - { forestCursorListCursor :: NonEmptyCursor (TreeCursor a b) (CTree b) - } +newtype ForestCursor a b = ForestCursor + { forestCursorListCursor :: NonEmptyCursor (TreeCursor a b) (CTree b) + } deriving (Show, Eq, Generic) instance (Validity a, Validity b) => Validity (ForestCursor a b) instance (NFData a, NFData b) => NFData (ForestCursor a b) +singletonForestCursor :: a -> ForestCursor a b +singletonForestCursor = ForestCursor . singletonNonEmptyCursor . singletonTreeCursor + makeForestCursor :: (b -> a) -> NonEmpty (CTree b) -> ForestCursor a b makeForestCursor g = ForestCursor . makeNonEmptyCursor (makeTreeCursor g) @@ -115,27 +132,27 @@ drawForestCursor :: (Show a, Show b) => ForestCursor a b -> String drawForestCursor ForestCursor {..} = drawForest $ - map showCTree (reverse $ nonEmptyCursorPrev forestCursorListCursor) ++ - [treeCursorWithPointer $ nonEmptyCursorCurrent forestCursorListCursor] ++ - map showCTree (nonEmptyCursorNext forestCursorListCursor) + map showCTree (reverse $ nonEmptyCursorPrev forestCursorListCursor) + ++ [treeCursorWithPointer $ nonEmptyCursorCurrent forestCursorListCursor] + ++ map showCTree (nonEmptyCursorNext forestCursorListCursor) mapForestCursor :: (a -> c) -> (b -> d) -> ForestCursor a b -> ForestCursor c d mapForestCursor f g = forestCursorListCursorL %~ mapNonEmptyCursor (mapTreeCursor f g) (fmap g) forestCursorListCursorL :: - Lens (ForestCursor a b) (ForestCursor c d) (NonEmptyCursor (TreeCursor a b) (CTree b)) (NonEmptyCursor (TreeCursor c d) (CTree d)) + Lens (ForestCursor a b) (ForestCursor c d) (NonEmptyCursor (TreeCursor a b) (CTree b)) (NonEmptyCursor (TreeCursor c d) (CTree d)) forestCursorListCursorL = lens forestCursorListCursor $ \fc lc -> fc {forestCursorListCursor = lc} forestCursorSelectedTreeL :: Lens' (ForestCursor a b) (TreeCursor a b) forestCursorSelectedTreeL = forestCursorListCursorL . nonEmptyCursorElemL forestCursorSelectPrevTreeCursor :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectPrevTreeCursor f g = forestCursorListCursorL $ nonEmptyCursorSelectPrev (rebuildTreeCursor f) (makeTreeCursor g) forestCursorSelectNextTreeCursor :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectNextTreeCursor f g = forestCursorListCursorL $ nonEmptyCursorSelectNext (rebuildTreeCursor f) (makeTreeCursor g) @@ -149,28 +166,41 @@ forestCursorSelectNext :: (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectNext f g fc = - (fc & forestCursorSelectedTreeL (treeCursorSelectNext f g)) <|> - forestCursorSelectNextTreeCursor f g fc + (fc & forestCursorSelectedTreeL (treeCursorSelectNext f g)) + <|> forestCursorSelectNextTreeCursor f g fc forestCursorSelectPrev :: (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectPrev f g fc = - (fc & forestCursorSelectedTreeL (treeCursorSelectPrev f g)) <|> - (forestCursorSelectPrevTreeCursor f g fc >>= - forestCursorSelectedTreeL (treeCursorSelectBelowAtEndRecursively f g)) <|> - forestCursorSelectPrevTreeCursor f g fc + (fc & forestCursorSelectedTreeL (treeCursorSelectPrev f g)) + <|> ( forestCursorSelectPrevTreeCursor f g fc + >>= forestCursorSelectedTreeL (treeCursorSelectBelowAtEndRecursively f g) + ) + <|> forestCursorSelectPrevTreeCursor f g fc forestCursorSelectNextOnSameLevel :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectNextOnSameLevel f g fc = - (fc & forestCursorSelectedTreeL (treeCursorSelectNextOnSameLevel f g)) <|> - forestCursorSelectNextTreeCursor f g fc + (fc & forestCursorSelectedTreeL (treeCursorSelectNextOnSameLevel f g)) + <|> forestCursorSelectNextTreeCursor f g fc forestCursorSelectPrevOnSameLevel :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectPrevOnSameLevel f g fc = - (fc & forestCursorSelectedTreeL (treeCursorSelectPrevOnSameLevel f g)) <|> - forestCursorSelectPrevTreeCursor f g fc + (fc & forestCursorSelectedTreeL (treeCursorSelectPrevOnSameLevel f g)) + <|> forestCursorSelectPrevTreeCursor f g fc +forestCursorSelectLastOnSameLevel :: (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectLastOnSameLevel f g fc = + case forestCursorSelectNextOnSameLevel f g fc of + Nothing -> fc + Just fc' -> forestCursorSelectLastOnSameLevel f g fc' + +forestCursorSelectFirstOnSameLevel :: (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectFirstOnSameLevel f g fc = + case forestCursorSelectPrevOnSameLevel f g fc of + Nothing -> fc + Just fc' -> forestCursorSelectLastOnSameLevel f g fc' + forestCursorSelectFirst :: (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b forestCursorSelectFirst f g fc = case forestCursorSelectPrevTreeCursor f g fc of @@ -193,11 +223,11 @@ forestCursorSelectAbove f g = forestCursorSelectedTreeL $ treeCursorSelectAbove f g forestCursorSelectBelowAtPos :: - (a -> b) -> (b -> a) -> Int -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> Int -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectBelowAtPos f g i = forestCursorSelectedTreeL $ treeCursorSelectBelowAtPos f g i forestCursorSelectBelowAtStart :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectBelowAtStart f g = forestCursorSelectedTreeL $ treeCursorSelectBelowAtStart f g forestCursorSelectBelowAtEnd :: (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) @@ -207,7 +237,7 @@ forestCursorSelection fc = nonEmptyCursorSelection $ fc ^. forestCursorListCursorL forestCursorSelectIndex :: - (a -> b) -> (b -> a) -> Int -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> Int -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectIndex f g i = forestCursorListCursorL (nonEmptyCursorSelectIndex (rebuildTreeCursor f) (makeTreeCursor g) i) @@ -232,7 +262,7 @@ forestCursorInsertEntireTree t = forestCursorListCursorL %~ nonEmptyCursorInsert (makeCTree t) forestCursorInsertAndSelectTreeCursor :: - (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b + (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b forestCursorInsertAndSelectTreeCursor f tc = forestCursorListCursorL %~ nonEmptyCursorInsertAndSelect (rebuildTreeCursor f) tc @@ -240,31 +270,29 @@ forestCursorAppendEntireTree t = forestCursorListCursorL %~ nonEmptyCursorAppend (makeCTree t) forestCursorAppendAndSelectTreeCursor :: - (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b + (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b forestCursorAppendAndSelectTreeCursor f tc = forestCursorListCursorL %~ nonEmptyCursorAppendAndSelect (rebuildTreeCursor f) tc forestCursorInsertTree :: Tree b -> ForestCursor a b -> ForestCursor a b forestCursorInsertTree t fc = fromMaybe (forestCursorInsertEntireTree t fc) $ - fc & forestCursorSelectedTreeL (treeCursorInsert t) + fc & forestCursorSelectedTreeL (treeCursorInsert t) forestCursorInsertAndSelectTree :: - (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b -forestCursorInsertAndSelectTree f g t fc = - fromMaybe (forestCursorInsertAndSelectTreeCursor f (makeTreeCursor g $ makeCTree t) fc) $ - fc & forestCursorSelectedTreeL (treeCursorInsertAndSelect f g t) + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertAndSelectTree f g (Node value forest) = + forestCursorInsertNodeAndSelect f (g value) (makeCForest forest) forestCursorAppendTree :: Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAppendTree t fc = fromMaybe (forestCursorAppendEntireTree t fc) $ - fc & forestCursorSelectedTreeL (treeCursorAppend t) + fc & forestCursorSelectedTreeL (treeCursorAppend t) forestCursorAppendAndSelectTree :: - (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b -forestCursorAppendAndSelectTree f g t fc = - fromMaybe (forestCursorAppendAndSelectTreeCursor f (makeTreeCursor g $ makeCTree t) fc) $ - fc & forestCursorSelectedTreeL (treeCursorAppendAndSelect f g t) + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendAndSelectTree f g (Node value forest) = + forestCursorAppendNodeAndSelect f (g value) (makeCForest forest) forestCursorInsert :: b -> ForestCursor a b -> ForestCursor a b forestCursorInsert b = forestCursorInsertTree $ Node b [] @@ -272,12 +300,28 @@ forestCursorInsertAndSelect :: (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b forestCursorInsertAndSelect f g b = forestCursorInsertAndSelectTree f g $ Node b [] +forestCursorInsertNodeSingleAndSelect :: (a -> b) -> a -> ForestCursor a b -> ForestCursor a b +forestCursorInsertNodeSingleAndSelect f value = forestCursorInsertNodeAndSelect f value EmptyCForest + +forestCursorInsertNodeAndSelect :: (a -> b) -> a -> CForest b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertNodeAndSelect f value forest fc = + fromMaybe (forestCursorInsertAndSelectTreeCursor f (makeNodeTreeCursor value forest) fc) $ + fc & forestCursorSelectedTreeL (treeCursorInsertNodeAndSelect f value forest) + forestCursorAppend :: b -> ForestCursor a b -> ForestCursor a b forestCursorAppend b = forestCursorAppendTree $ Node b [] forestCursorAppendAndSelect :: (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b forestCursorAppendAndSelect f g b = forestCursorAppendAndSelectTree f g $ Node b [] +forestCursorAppendNodeSingleAndSelect :: (a -> b) -> a -> ForestCursor a b -> ForestCursor a b +forestCursorAppendNodeSingleAndSelect f value = forestCursorAppendNodeAndSelect f value EmptyCForest + +forestCursorAppendNodeAndSelect :: (a -> b) -> a -> CForest b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendNodeAndSelect f value forest fc = + fromMaybe (forestCursorAppendAndSelectTreeCursor f (makeNodeTreeCursor value forest) fc) $ + fc & forestCursorSelectedTreeL (treeCursorAppendNodeAndSelect f value forest) + forestCursorAddChildTreeToNodeAtPos :: Int -> Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildTreeToNodeAtPos i t = forestCursorSelectedTreeL %~ treeCursorAddChildAtPos i t @@ -297,75 +341,133 @@ forestCursorAddChildToNodeAtEnd :: b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildToNodeAtEnd b = forestCursorAddChildTreeToNodeAtEnd $ Node b [] +forestCursorAddChildTreeToNodeAtPosAndSelect :: + (a -> b) -> (b -> a) -> Int -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtPosAndSelect f g i t = + forestCursorSelectedTreeL %~ treeCursorAddChildAtPosAndSelect f g i t + +forestCursorAddChildTreeToNodeAtStartAndSelect :: + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtStartAndSelect f g t = + forestCursorSelectedTreeL %~ treeCursorAddChildAtStartAndSelect f g t + +forestCursorAddChildTreeToNodeAtEndAndSelect :: + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtEndAndSelect f g t fc = + fc & forestCursorSelectedTreeL %~ treeCursorAddChildAtEndAndSelect f g t + +forestCursorAddChildToNodeAtPosAndSelect :: + (a -> b) -> (b -> a) -> Int -> b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtPosAndSelect f g i b = + forestCursorAddChildTreeToNodeAtPosAndSelect f g i $ Node b [] + +forestCursorAddChildToNodeAtStartAndSelect :: + (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtStartAndSelect f g b = + forestCursorAddChildTreeToNodeAtStartAndSelect f g $ Node b [] + +forestCursorAddChildToNodeAtEndAndSelect :: + (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtEndAndSelect f g b = + forestCursorAddChildTreeToNodeAtEndAndSelect f g $ Node b [] + +forestCursorAddChildNodeSingleToNodeAtPosAndSelect :: + (a -> b) -> Int -> a -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeSingleToNodeAtPosAndSelect f i t = forestCursorSelectedTreeL %~ treeCursorAddChildNodeSingleAtPosAndSelect f i t + +forestCursorAddChildNodeSingleToNodeAtStartAndSelect :: + (a -> b) -> a -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeSingleToNodeAtStartAndSelect f t = forestCursorSelectedTreeL %~ treeCursorAddChildNodeSingleAtStartAndSelect f t + +forestCursorAddChildNodeSingleToNodeAtEndAndSelect :: + (a -> b) -> a -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeSingleToNodeAtEndAndSelect f t = forestCursorSelectedTreeL %~ treeCursorAddChildNodeSingleAtEndAndSelect f t + +forestCursorAddChildNodeToNodeAtPosAndSelect :: + (a -> b) -> Int -> a -> Forest b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeToNodeAtPosAndSelect f i t ts = forestCursorSelectedTreeL %~ treeCursorAddChildNodeAtPosAndSelect f i t ts + +forestCursorAddChildNodeToNodeAtStartAndSelect :: + (a -> b) -> a -> Forest b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeToNodeAtStartAndSelect f t ts = forestCursorSelectedTreeL %~ treeCursorAddChildNodeAtStartAndSelect f t ts + +forestCursorAddChildNodeToNodeAtEndAndSelect :: + (a -> b) -> a -> Forest b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildNodeToNodeAtEndAndSelect f t ts = forestCursorSelectedTreeL %~ treeCursorAddChildNodeAtEndAndSelect f t ts + forestCursorRemoveElemAndSelectPrev :: - (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) + (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) forestCursorRemoveElemAndSelectPrev g fc = - case fc & - focusPossibleDeleteOrUpdate - forestCursorSelectedTreeL - (treeCursorDeleteElemAndSelectPrevious g) of + case fc + & focusPossibleDeleteOrUpdate + forestCursorSelectedTreeL + (treeCursorDeleteElemAndSelectPrevious g) of Just Deleted -> - fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorRemoveElemAndSelectPrev (makeTreeCursor g)) + fc + & focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorRemoveElemAndSelectPrev (makeTreeCursor g)) r -> r forestCursorDeleteElemAndSelectNext :: - (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) + (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) forestCursorDeleteElemAndSelectNext g fc = - case fc & - focusPossibleDeleteOrUpdate forestCursorSelectedTreeL (treeCursorDeleteElemAndSelectNext g) of + case fc + & focusPossibleDeleteOrUpdate forestCursorSelectedTreeL (treeCursorDeleteElemAndSelectNext g) of Just Deleted -> - fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g)) + fc + & focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g)) r -> r forestCursorRemoveElem :: (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) forestCursorRemoveElem g fc = - (fc & forestCursorSelectedTreeL (treeCursorRemoveElem g)) <|> - (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) + (fc & forestCursorSelectedTreeL (treeCursorRemoveElem g)) + <|> (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) forestCursorDeleteElem :: (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) forestCursorDeleteElem g fc = - (fc & forestCursorSelectedTreeL (treeCursorDeleteElem g)) <|> - (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) + (fc & forestCursorSelectedTreeL (treeCursorDeleteElem g)) + <|> (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) forestCursorRemoveSubTreeAndSelectPrev :: - (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) + (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) forestCursorRemoveSubTreeAndSelectPrev g fc = joinPossibleDeletes - (fc & - focusPossibleDeleteOrUpdate - forestCursorSelectedTreeL - (treeCursorDeleteSubTreeAndSelectPrevious g)) - (fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorRemoveElemAndSelectPrev (makeTreeCursor g))) + ( fc + & focusPossibleDeleteOrUpdate + forestCursorSelectedTreeL + (treeCursorDeleteSubTreeAndSelectPrevious g) + ) + ( fc + & focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorRemoveElemAndSelectPrev (makeTreeCursor g)) + ) forestCursorDeleteSubTreeAndSelectNext :: - (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) + (b -> a) -> ForestCursor a b -> Maybe (DeleteOrUpdate (ForestCursor a b)) forestCursorDeleteSubTreeAndSelectNext g fc = joinPossibleDeletes - (fc & - focusPossibleDeleteOrUpdate forestCursorSelectedTreeL (treeCursorDeleteSubTreeAndSelectNext g)) - (fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g))) + ( fc + & focusPossibleDeleteOrUpdate forestCursorSelectedTreeL (treeCursorDeleteSubTreeAndSelectNext g) + ) + ( fc + & focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g)) + ) forestCursorRemoveSubTree :: (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) forestCursorRemoveSubTree g fc = - (fc & forestCursorSelectedTreeL (treeCursorRemoveSubTree g)) <|> - (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) + (fc & forestCursorSelectedTreeL (treeCursorRemoveSubTree g)) + <|> (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) forestCursorDeleteSubTree :: (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) forestCursorDeleteSubTree g fc = - (fc & forestCursorSelectedTreeL (treeCursorDeleteSubTree g)) <|> - (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) + (fc & forestCursorSelectedTreeL (treeCursorDeleteSubTree g)) + <|> (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) forestCursorAddRoot :: (a -> b) -> (b -> a) -> ForestCursor a b -> a -> TreeCursor a b forestCursorAddRoot f g fc v = @@ -392,9 +494,9 @@ SwapperIsTopNode -> case nonEmptyCursorPrev ne of [] -> Nothing - (t:ts) -> + (t : ts) -> pure $ - ForestCursor ne {nonEmptyCursorPrev = ts, nonEmptyCursorNext = t : nonEmptyCursorNext ne} + ForestCursor ne {nonEmptyCursorPrev = ts, nonEmptyCursorNext = t : nonEmptyCursorNext ne} -- | Swaps the current node with the next node on the same level -- @@ -417,9 +519,9 @@ SwapperIsTopNode -> case nonEmptyCursorNext ne of [] -> Nothing - (t:ts) -> + (t : ts) -> pure $ - ForestCursor ne {nonEmptyCursorPrev = t : nonEmptyCursorPrev ne, nonEmptyCursorNext = ts} + ForestCursor ne {nonEmptyCursorPrev = t : nonEmptyCursorPrev ne, nonEmptyCursorNext = ts} -- | Promotes the current node to the level of its parent. -- @@ -461,7 +563,7 @@ _ -> case treeAboveLefts ta of [] -> Nothing - (CNode t ls:ts) -> + (CNode t ls : ts) -> pure $ CNode t (openForest $ unpackCForest ls ++ unpackCForest (treeBelow tc)) : ts let ta' = ta {treeAboveLefts = lefts} let tc' = tc {treeAbove = Just ta'} @@ -471,11 +573,11 @@ Updated tc'' -> pure tc'' pure $ ForestCursor $ - ne - { nonEmptyCursorPrev = rebuildTreeCursor f tc'' : nonEmptyCursorPrev ne - , nonEmptyCursorCurrent = - singletonTreeCursor $ treeCurrent $ fc ^. forestCursorSelectedTreeL - } + ne + { nonEmptyCursorPrev = rebuildTreeCursor f tc'' : nonEmptyCursorPrev ne, + nonEmptyCursorCurrent = + singletonTreeCursor $ treeCurrent $ fc ^. forestCursorSelectedTreeL + } -- | Promotes the current node to the level of its parent. -- @@ -513,11 +615,11 @@ Deleted -> Nothing -- Cannot happen, otherwise we would have gotten 'CannotPromoteTopNode'. Updated tc' -> pure $ - ForestCursor $ - ne - { nonEmptyCursorPrev = rebuildTreeCursor f tc' : nonEmptyCursorPrev ne - , nonEmptyCursorCurrent = (fc ^. forestCursorSelectedTreeL) {treeAbove = Nothing} - } + ForestCursor $ + ne + { nonEmptyCursorPrev = rebuildTreeCursor f tc' : nonEmptyCursorPrev ne, + nonEmptyCursorCurrent = (fc ^. forestCursorSelectedTreeL) {treeAbove = Nothing} + } -- | Demotes the current node to the level of its children. -- @@ -545,11 +647,12 @@ CannotDemoteTopNode -> case nonEmptyCursorPrev ne of [] -> Nothing - (CNode v vts:ts) -> do + (CNode v vts : ts) -> do let CNode v' vts' = rebuildTreeCursor f (fc ^. forestCursorSelectedTreeL) let n' = CNode v $ - openForest $ unpackCForest vts ++ CNode v' emptyCForest : unpackCForest vts' + openForest $ + unpackCForest vts ++ CNode v' emptyCForest : unpackCForest vts' tc <- makeTreeCursorWithSelection f g (SelectChild (lengthCForest vts) SelectNode) n' pure $ ForestCursor ne {nonEmptyCursorPrev = ts, nonEmptyCursorCurrent = tc} NoSiblingsToDemoteUnder -> Nothing @@ -578,11 +681,11 @@ CannotDemoteTopNode -> case nonEmptyCursorPrev ne of [] -> Nothing - (CNode v vts:ts) -> do + (CNode v vts : ts) -> do let n' = CNode v $ - openForest $ - unpackCForest vts ++ [rebuildTreeCursor f (fc ^. forestCursorSelectedTreeL)] + openForest $ + unpackCForest vts ++ [rebuildTreeCursor f (fc ^. forestCursorSelectedTreeL)] tc <- makeTreeCursorWithSelection f g (SelectChild (lengthCForest vts) SelectNode) n' pure $ ForestCursor ne {nonEmptyCursorPrev = ts, nonEmptyCursorCurrent = tc} NoSiblingsToDemoteUnder -> Nothing @@ -610,22 +713,22 @@ Nothing -> let t = fc ^. forestCursorSelectedTreeL in ForestCursor $ - ne - { nonEmptyCursorCurrent = - TreeCursor - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Nothing - , treeAboveNode = b1 - , treeAboveRights = [] - } - , treeCurrent = treeCurrent t - , treeBelow = emptyCForest - } - , nonEmptyCursorNext = CNode b2 (treeBelow t) : nonEmptyCursorNext ne - } + ne + { nonEmptyCursorCurrent = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = Nothing, + treeAboveNode = b1, + treeAboveRights = [] + }, + treeCurrent = treeCurrent t, + treeBelow = emptyCForest + }, + nonEmptyCursorNext = CNode b2 (treeBelow t) : nonEmptyCursorNext ne + } -- | Demotes the current subtree to the level of its children, by adding a root. -- diff --git a/src/Cursor/List.hs b/src/Cursor/List.hs --- a/src/Cursor/List.hs +++ b/src/Cursor/List.hs @@ -1,47 +1,49 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.List - ( ListCursor(..) - , emptyListCursor - , makeListCursor - , makeListCursorWithSelection - , rebuildListCursor - , listCursorNull - , listCursorLength - , listCursorIndex - , listCursorSelectPrev - , listCursorSelectNext - , listCursorSelectIndex - , listCursorSelectStart - , listCursorSelectEnd - , listCursorPrevItem - , listCursorNextItem - , listCursorInsert - , listCursorAppend - , listCursorRemove - , listCursorDelete - , listCursorSplit - , listCursorCombine - , traverseListCursor - , foldListCursor - ) where - -import GHC.Generics (Generic) - -import Data.Validity + ( ListCursor (..), + emptyListCursor, + makeListCursor, + makeListCursorWithSelection, + rebuildListCursor, + listCursorNull, + listCursorLength, + listCursorIndex, + listCursorSelectPrev, + listCursorSelectNext, + listCursorSelectIndex, + listCursorSelectStart, + listCursorSelectEnd, + listCursorPrevItem, + listCursorNextItem, + listCursorPrevUntil, + listCursorNextUntil, + listCursorInsert, + listCursorAppend, + listCursorInsertList, + listCursorAppendList, + listCursorRemove, + listCursorDelete, + listCursorSplit, + listCursorCombine, + traverseListCursor, + foldListCursor, + ) +where import Control.DeepSeq - import Cursor.Types +import Data.Validity +import GHC.Generics (Generic) -data ListCursor a = - ListCursor - { listCursorPrev :: [a] -- ^ In reverse order - , listCursorNext :: [a] - } +data ListCursor a = ListCursor + { -- | In reverse order + listCursorPrev :: [a], + listCursorNext :: [a] + } deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (ListCursor a) @@ -76,13 +78,13 @@ listCursorSelectPrev tc = case listCursorPrev tc of [] -> Nothing - (c:cs) -> Just ListCursor {listCursorPrev = cs, listCursorNext = c : listCursorNext tc} + (c : cs) -> Just ListCursor {listCursorPrev = cs, listCursorNext = c : listCursorNext tc} listCursorSelectNext :: ListCursor a -> Maybe (ListCursor a) listCursorSelectNext tc = case listCursorNext tc of [] -> Nothing - (c:cs) -> Just ListCursor {listCursorPrev = c : listCursorPrev tc, listCursorNext = cs} + (c : cs) -> Just ListCursor {listCursorPrev = c : listCursorPrev tc, listCursorNext = cs} listCursorSelectIndex :: Int -> ListCursor a -> ListCursor a listCursorSelectIndex ix_ lc = @@ -106,20 +108,46 @@ listCursorPrevItem lc = case listCursorPrev lc of [] -> Nothing - (c:_) -> Just c + (c : _) -> Just c listCursorNextItem :: ListCursor a -> Maybe a listCursorNextItem lc = case listCursorNext lc of [] -> Nothing - (c:_) -> Just c + (c : _) -> Just c +listCursorPrevUntil :: (a -> Bool) -> ListCursor a -> ListCursor a +listCursorPrevUntil p = go + where + go lc = + case listCursorPrev lc of + [] -> lc + (c : _) + | p c -> lc + _ -> maybe lc go (listCursorSelectPrev lc) + +listCursorNextUntil :: (a -> Bool) -> ListCursor a -> ListCursor a +listCursorNextUntil p = go + where + go lc = + case listCursorNext lc of + [] -> lc + (c : _) + | p c -> lc + _ -> maybe lc go (listCursorSelectNext lc) + listCursorInsert :: a -> ListCursor a -> ListCursor a listCursorInsert c lc = lc {listCursorPrev = c : listCursorPrev lc} listCursorAppend :: a -> ListCursor a -> ListCursor a listCursorAppend c lc = lc {listCursorNext = c : listCursorNext lc} +listCursorInsertList :: [a] -> ListCursor a -> ListCursor a +listCursorInsertList l lc = lc {listCursorPrev = reverse l ++ listCursorPrev lc} + +listCursorAppendList :: [a] -> ListCursor a -> ListCursor a +listCursorAppendList l lc = lc {listCursorNext = l ++ listCursorNext lc} + listCursorRemove :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a)) listCursorRemove tc = case listCursorPrev tc of @@ -127,7 +155,7 @@ case listCursorNext tc of [] -> Just Deleted _ -> Nothing - (_:prev) -> Just $ Updated $ tc {listCursorPrev = prev} + (_ : prev) -> Just $ Updated $ tc {listCursorPrev = prev} listCursorDelete :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a)) listCursorDelete tc = @@ -136,17 +164,20 @@ case listCursorPrev tc of [] -> Just Deleted _ -> Nothing - (_:next) -> Just $ Updated $ tc {listCursorNext = next} + (_ : next) -> Just $ Updated $ tc {listCursorNext = next} listCursorSplit :: ListCursor a -> (ListCursor a, ListCursor a) listCursorSplit ListCursor {..} = - ( ListCursor {listCursorPrev = listCursorPrev, listCursorNext = []} - , ListCursor {listCursorPrev = [], listCursorNext = listCursorNext}) + ( ListCursor {listCursorPrev = listCursorPrev, listCursorNext = []}, + ListCursor {listCursorPrev = [], listCursorNext = listCursorNext} + ) listCursorCombine :: ListCursor a -> ListCursor a -> ListCursor a listCursorCombine lc1 lc2 = ListCursor - {listCursorPrev = reverse $ rebuildListCursor lc1, listCursorNext = rebuildListCursor lc2} + { listCursorPrev = reverse $ rebuildListCursor lc1, + listCursorNext = rebuildListCursor lc2 + } traverseListCursor :: ([a] -> [a] -> f b) -> ListCursor a -> f b traverseListCursor = foldListCursor diff --git a/src/Cursor/List/NonEmpty.hs b/src/Cursor/List/NonEmpty.hs --- a/src/Cursor/List/NonEmpty.hs +++ b/src/Cursor/List/NonEmpty.hs @@ -1,65 +1,60 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.List.NonEmpty - ( NonEmptyCursor(..) - , makeNonEmptyCursor - , makeNonEmptyCursorWithSelection - , singletonNonEmptyCursor - , rebuildNonEmptyCursor - , nonEmptyCursorElemL - , mapNonEmptyCursor - , nonEmptyCursorSelectPrev - , nonEmptyCursorSelectNext - , nonEmptyCursorSelectFirst - , nonEmptyCursorSelectLast - , nonEmptyCursorSelection - , nonEmptyCursorSelectIndex - , nonEmptyCursorInsert - , nonEmptyCursorAppend - , nonEmptyCursorInsertAndSelect - , nonEmptyCursorAppendAndSelect - , nonEmptyCursorInsertAtStart - , nonEmptyCursorAppendAtEnd - , nonEmptyCursorInsertAtStartAndSelect - , nonEmptyCursorAppendAtEndAndSelect - , nonEmptyCursorRemoveElemAndSelectPrev - , nonEmptyCursorDeleteElemAndSelectNext - , nonEmptyCursorRemoveElem - , nonEmptyCursorDeleteElem - , nonEmptyCursorSearch - , nonEmptyCursorSelectOrAdd - , renderNonEmptyCursor - , nonemptyPrepend - , nonemptyAppend - , traverseNonEmptyCursor - , foldNonEmptyCursor - ) where - -import GHC.Generics (Generic) - -import Data.Maybe -import Data.Validity + ( NonEmptyCursor (..), + makeNonEmptyCursor, + makeNonEmptyCursorWithSelection, + singletonNonEmptyCursor, + rebuildNonEmptyCursor, + nonEmptyCursorElemL, + mapNonEmptyCursor, + nonEmptyCursorSelectPrev, + nonEmptyCursorSelectNext, + nonEmptyCursorSelectFirst, + nonEmptyCursorSelectLast, + nonEmptyCursorSelection, + nonEmptyCursorSelectIndex, + nonEmptyCursorInsert, + nonEmptyCursorAppend, + nonEmptyCursorInsertAndSelect, + nonEmptyCursorAppendAndSelect, + nonEmptyCursorInsertAtStart, + nonEmptyCursorAppendAtEnd, + nonEmptyCursorInsertAtStartAndSelect, + nonEmptyCursorAppendAtEndAndSelect, + nonEmptyCursorRemoveElemAndSelectPrev, + nonEmptyCursorDeleteElemAndSelectNext, + nonEmptyCursorRemoveElem, + nonEmptyCursorDeleteElem, + nonEmptyCursorSearch, + nonEmptyCursorSelectOrAdd, + renderNonEmptyCursor, + nonemptyPrepend, + nonemptyAppend, + traverseNonEmptyCursor, + foldNonEmptyCursor, + ) +where import Control.DeepSeq import Control.Monad - -import Lens.Micro - -import Data.List.NonEmpty (NonEmpty(..), (<|)) -import qualified Data.List.NonEmpty as NE - import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Validity +import GHC.Generics (Generic) +import Lens.Micro -- | A 'nonempty list' cursor -data NonEmptyCursor a b = - NonEmptyCursor - { nonEmptyCursorPrev :: [b] -- In reverse order - , nonEmptyCursorCurrent :: a - , nonEmptyCursorNext :: [b] - } +data NonEmptyCursor a b = NonEmptyCursor + { nonEmptyCursorPrev :: [b], -- In reverse order + nonEmptyCursorCurrent :: a, + nonEmptyCursorNext :: [b] + } deriving (Show, Eq, Generic, Functor) instance (Validity a, Validity b) => Validity (NonEmptyCursor a b) @@ -74,7 +69,10 @@ (l, m, r) <- applyNonEmptySelection ne i pure NonEmptyCursor - {nonEmptyCursorPrev = reverse l, nonEmptyCursorCurrent = g m, nonEmptyCursorNext = r} + { nonEmptyCursorPrev = reverse l, + nonEmptyCursorCurrent = g m, + nonEmptyCursorNext = r + } where applyNonEmptySelection :: NonEmpty a -> Int -> Maybe ([a], a, [a]) applyNonEmptySelection (c :| rest) i_ @@ -96,9 +94,9 @@ mapNonEmptyCursor :: (a -> c) -> (b -> d) -> NonEmptyCursor a b -> NonEmptyCursor c d mapNonEmptyCursor f g NonEmptyCursor {..} = NonEmptyCursor - { nonEmptyCursorPrev = map g nonEmptyCursorPrev - , nonEmptyCursorCurrent = f nonEmptyCursorCurrent - , nonEmptyCursorNext = map g nonEmptyCursorNext + { nonEmptyCursorPrev = map g nonEmptyCursorPrev, + nonEmptyCursorCurrent = f nonEmptyCursorCurrent, + nonEmptyCursorNext = map g nonEmptyCursorNext } nonEmptyCursorElemL :: Lens (NonEmptyCursor a c) (NonEmptyCursor b c) a b @@ -108,25 +106,25 @@ nonEmptyCursorSelectPrev f g lec = case nonEmptyCursorPrev lec of [] -> Nothing - (e:rest) -> + (e : rest) -> Just $ - lec - { nonEmptyCursorPrev = rest - , nonEmptyCursorCurrent = g e - , nonEmptyCursorNext = f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec - } + lec + { nonEmptyCursorPrev = rest, + nonEmptyCursorCurrent = g e, + nonEmptyCursorNext = f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec + } nonEmptyCursorSelectNext :: (a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) nonEmptyCursorSelectNext f g lec = case nonEmptyCursorNext lec of [] -> Nothing - (e:rest) -> + (e : rest) -> Just $ - lec - { nonEmptyCursorPrev = f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec - , nonEmptyCursorCurrent = g e - , nonEmptyCursorNext = rest - } + lec + { nonEmptyCursorPrev = f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec, + nonEmptyCursorCurrent = g e, + nonEmptyCursorNext = rest + } nonEmptyCursorSelectFirst :: (a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorSelectFirst f g lec = @@ -144,7 +142,7 @@ nonEmptyCursorSelection = length . nonEmptyCursorPrev nonEmptyCursorSelectIndex :: - (a -> b) -> (b -> a) -> Int -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) + (a -> b) -> (b -> a) -> Int -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) nonEmptyCursorSelectIndex f g i nec | i < nonEmptyCursorSelection nec = nonEmptyCursorSelectPrev f g nec >>= nonEmptyCursorSelectIndex f g i @@ -161,15 +159,15 @@ nonEmptyCursorInsertAndSelect :: (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorInsertAndSelect f c lec = lec - { nonEmptyCursorCurrent = c - , nonEmptyCursorNext = f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec + { nonEmptyCursorCurrent = c, + nonEmptyCursorNext = f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec } nonEmptyCursorAppendAndSelect :: (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorAppendAndSelect f c lec = lec - { nonEmptyCursorCurrent = c - , nonEmptyCursorPrev = f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec + { nonEmptyCursorCurrent = c, + nonEmptyCursorPrev = f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec } nonEmptyCursorInsertAtStart :: b -> NonEmptyCursor a b -> NonEmptyCursor a b @@ -179,34 +177,34 @@ nonEmptyCursorAppendAtEnd c lec = lec {nonEmptyCursorNext = nonEmptyCursorNext lec ++ [c]} nonEmptyCursorInsertAtStartAndSelect :: - (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorInsertAtStartAndSelect f g c = nonEmptyCursorSelectFirst f g . nonEmptyCursorInsertAtStart c nonEmptyCursorAppendAtEndAndSelect :: - (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorAppendAtEndAndSelect f g c = nonEmptyCursorSelectLast f g . nonEmptyCursorAppendAtEnd c nonEmptyCursorRemoveElemAndSelectPrev :: - (b -> a) -> NonEmptyCursor a b -> Maybe (DeleteOrUpdate (NonEmptyCursor a b)) + (b -> a) -> NonEmptyCursor a b -> Maybe (DeleteOrUpdate (NonEmptyCursor a b)) nonEmptyCursorRemoveElemAndSelectPrev g lec = case nonEmptyCursorPrev lec of [] -> case nonEmptyCursorNext lec of [] -> Just Deleted _ -> Nothing - (e:rest) -> Just $ Updated $ lec {nonEmptyCursorPrev = rest, nonEmptyCursorCurrent = g e} + (e : rest) -> Just $ Updated $ lec {nonEmptyCursorPrev = rest, nonEmptyCursorCurrent = g e} nonEmptyCursorDeleteElemAndSelectNext :: - (b -> a) -> NonEmptyCursor a b -> Maybe (DeleteOrUpdate (NonEmptyCursor a b)) + (b -> a) -> NonEmptyCursor a b -> Maybe (DeleteOrUpdate (NonEmptyCursor a b)) nonEmptyCursorDeleteElemAndSelectNext g lec = case nonEmptyCursorNext lec of [] -> case nonEmptyCursorPrev lec of [] -> Just Deleted _ -> Nothing - (e:rest) -> Just $ Updated $ lec {nonEmptyCursorCurrent = g e, nonEmptyCursorNext = rest} + (e : rest) -> Just $ Updated $ lec {nonEmptyCursorCurrent = g e, nonEmptyCursorNext = rest} nonEmptyCursorRemoveElem :: (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) nonEmptyCursorRemoveElem g lec = @@ -221,7 +219,7 @@ (nonEmptyCursorRemoveElemAndSelectPrev g lec) nonEmptyCursorSearch :: - (a -> b) -> (b -> a) -> (a -> Bool) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) + (a -> b) -> (b -> a) -> (a -> Bool) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) nonEmptyCursorSearch f g p nec = if p $ nonEmptyCursorCurrent nec then Just nec @@ -236,7 +234,7 @@ else look func nec' nonEmptyCursorSelectOrAdd :: - (a -> b) -> (b -> a) -> (a -> Bool) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> (b -> a) -> (a -> Bool) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorSelectOrAdd f g p a nec = case nonEmptyCursorSearch f g p nec of Nothing -> nonEmptyCursorAppendAndSelect f a nec diff --git a/src/Cursor/Map.hs b/src/Cursor/Map.hs --- a/src/Cursor/Map.hs +++ b/src/Cursor/Map.hs @@ -3,61 +3,59 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Map - ( MapCursor(..) - , makeMapCursor - , makeMapCursorWithSelection - , singletonMapCursorKey - , singletonMapCursorValue - , rebuildMapCursor - , mapMapCursor - , mapCursorNonEmptyCursorL - , mapCursorElemL - , mapCursorSelectKey - , mapCursorSelectValue - , mapCursorToggleSelected - , mapCursorSelectPrev - , mapCursorSelectNext - , mapCursorSelectFirst - , mapCursorSelectLast - , mapCursorSelection - , mapCursorSelectIndex - , mapCursorInsert - , mapCursorAppend - , mapCursorInsertAndSelectKey - , mapCursorAppendAndSelectKey - , mapCursorInsertAndSelectValue - , mapCursorAppendAndSelectValue - , mapCursorRemoveElemAndSelectPrev - , mapCursorDeleteElemAndSelectNext - , mapCursorRemoveElem - , mapCursorDeleteElem - , mapCursorSearch - , mapCursorSelectOrAdd - , traverseMapCursor - , foldMapCursor - , module Cursor.Map.KeyValue - ) where - -import GHC.Generics (Generic) - -import Data.Validity -import Data.Validity.Tree () - -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe + ( MapCursor (..), + makeMapCursor, + makeMapCursorWithSelection, + singletonMapCursorKey, + singletonMapCursorValue, + rebuildMapCursor, + mapMapCursor, + mapCursorNonEmptyCursorL, + mapCursorElemL, + mapCursorElemSelection, + mapCursorSelectKey, + mapCursorSelectValue, + mapCursorToggleSelected, + mapCursorSelectPrev, + mapCursorSelectNext, + mapCursorSelectFirst, + mapCursorSelectLast, + mapCursorSelection, + mapCursorSelectIndex, + mapCursorInsert, + mapCursorAppend, + mapCursorInsertAndSelectKey, + mapCursorAppendAndSelectKey, + mapCursorInsertAndSelectValue, + mapCursorAppendAndSelectValue, + mapCursorRemoveElemAndSelectPrev, + mapCursorDeleteElemAndSelectNext, + mapCursorRemoveElem, + mapCursorDeleteElem, + mapCursorSearch, + mapCursorSelectOrAdd, + traverseMapCursor, + mapCursorTraverseKeyCase, + mapCursorTraverseValueCase, + foldMapCursor, + module Cursor.Map.KeyValue, + ) +where import Control.DeepSeq - -import Lens.Micro - import Cursor.List.NonEmpty import Cursor.Map.KeyValue import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Validity +import Data.Validity.Tree () +import GHC.Generics (Generic) +import Lens.Micro -newtype MapCursor kc vc k v = - MapCursor - { mapCursorList :: NonEmptyCursor (KeyValueCursor kc vc k v) (k, v) - } +newtype MapCursor kc vc k v = MapCursor + { mapCursorList :: NonEmptyCursor (KeyValueCursor kc vc k v) (k, v) + } deriving (Show, Eq, Generic) instance (Validity kc, Validity vc, Validity k, Validity v) => Validity (MapCursor kc vc k v) @@ -83,20 +81,35 @@ rebuildMapCursor f g = rebuildNonEmptyCursor (rebuildKeyValueCursor f g) . mapCursorList mapMapCursor :: - (kc -> lc) -> (vc -> wc) -> (k -> l) -> (v -> w) -> MapCursor kc vc k v -> MapCursor lc wc l w + (kc -> lc) -> (vc -> wc) -> (k -> l) -> (v -> w) -> MapCursor kc vc k v -> MapCursor lc wc l w mapMapCursor a b c d = mapCursorNonEmptyCursorL %~ mapNonEmptyCursor (mapKeyValueCursor a b c d) (\(k, v) -> (c k, d v)) mapCursorNonEmptyCursorL :: - Lens (MapCursor kc vc k v) (MapCursor lc wc l w) (NonEmptyCursor (KeyValueCursor kc vc k v) ( k - , v)) (NonEmptyCursor (KeyValueCursor lc wc l w) ( l - , w)) + Lens + (MapCursor kc vc k v) + (MapCursor lc wc l w) + ( NonEmptyCursor + (KeyValueCursor kc vc k v) + ( k, + v + ) + ) + ( NonEmptyCursor + (KeyValueCursor lc wc l w) + ( l, + w + ) + ) mapCursorNonEmptyCursorL = lens mapCursorList $ \mc ne -> mc {mapCursorList = ne} mapCursorElemL :: - Lens (MapCursor kc vc k v) (MapCursor kc' vc' k v) (KeyValueCursor kc vc k v) (KeyValueCursor kc' vc' k v) + Lens (MapCursor kc vc k v) (MapCursor kc' vc' k v) (KeyValueCursor kc vc k v) (KeyValueCursor kc' vc' k v) mapCursorElemL = mapCursorNonEmptyCursorL . nonEmptyCursorElemL +mapCursorElemSelection :: MapCursor kc vc k v -> KeyValueToggle +mapCursorElemSelection mc = keyValueCursorSelection $ mc ^. mapCursorElemL + mapCursorSelectKey :: (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorSelectKey g h = mapCursorElemL %~ keyValueCursorSelectKey g h @@ -104,26 +117,26 @@ mapCursorSelectValue f i = mapCursorElemL %~ keyValueCursorSelectValue f i mapCursorToggleSelected :: - (kc -> k) -> (k -> kc) -> (vc -> v) -> (v -> vc) -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (k -> kc) -> (vc -> v) -> (v -> vc) -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorToggleSelected f g h i = mapCursorElemL %~ keyValueCursorToggleSelected f g h i mapCursorSelectPrev :: - (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> Maybe (MapCursor kc vc k v) + (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> Maybe (MapCursor kc vc k v) mapCursorSelectPrev f g h = mapCursorNonEmptyCursorL $ nonEmptyCursorSelectPrev (rebuild f h) (make g) mapCursorSelectNext :: - (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> Maybe (MapCursor kc vc k v) + (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> Maybe (MapCursor kc vc k v) mapCursorSelectNext f g h = mapCursorNonEmptyCursorL $ nonEmptyCursorSelectNext (rebuild f h) (make g) mapCursorSelectFirst :: - (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorSelectFirst f g h = mapCursorNonEmptyCursorL %~ nonEmptyCursorSelectFirst (rebuild f h) (make g) mapCursorSelectLast :: - (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorSelectLast f g h = mapCursorNonEmptyCursorL %~ nonEmptyCursorSelectLast (rebuild f h) (make g) @@ -131,12 +144,12 @@ mapCursorSelection = nonEmptyCursorSelection . mapCursorList mapCursorSelectIndex :: - (kc -> k) - -> (k -> kc) - -> (vc -> v) - -> Int - -> MapCursor kc vc k v - -> Maybe (MapCursor kc vc k v) + (kc -> k) -> + (k -> kc) -> + (vc -> v) -> + Int -> + MapCursor kc vc k v -> + Maybe (MapCursor kc vc k v) mapCursorSelectIndex f g h i = mapCursorNonEmptyCursorL (nonEmptyCursorSelectIndex (rebuild f h) (make g) i) @@ -147,40 +160,40 @@ mapCursorAppend k v = mapCursorNonEmptyCursorL %~ nonEmptyCursorAppend (k, v) mapCursorInsertAndSelectKey :: - (kc -> k) -> (vc -> v) -> kc -> v -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (vc -> v) -> kc -> v -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorInsertAndSelectKey f h kc v = - mapCursorNonEmptyCursorL %~ - nonEmptyCursorInsertAndSelect (rebuild f h) (makeKeyValueCursorKey kc v) + mapCursorNonEmptyCursorL + %~ nonEmptyCursorInsertAndSelect (rebuild f h) (makeKeyValueCursorKey kc v) mapCursorAppendAndSelectKey :: - (kc -> k) -> (vc -> v) -> kc -> v -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (vc -> v) -> kc -> v -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorAppendAndSelectKey f h kc v = - mapCursorNonEmptyCursorL %~ - nonEmptyCursorAppendAndSelect (rebuild f h) (makeKeyValueCursorKey kc v) + mapCursorNonEmptyCursorL + %~ nonEmptyCursorAppendAndSelect (rebuild f h) (makeKeyValueCursorKey kc v) mapCursorInsertAndSelectValue :: - (kc -> k) -> (vc -> v) -> k -> vc -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (vc -> v) -> k -> vc -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorInsertAndSelectValue f h k vc = - mapCursorNonEmptyCursorL %~ - nonEmptyCursorInsertAndSelect (rebuild f h) (makeKeyValueCursorValue k vc) + mapCursorNonEmptyCursorL + %~ nonEmptyCursorInsertAndSelect (rebuild f h) (makeKeyValueCursorValue k vc) mapCursorAppendAndSelectValue :: - (kc -> k) -> (vc -> v) -> k -> vc -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (vc -> v) -> k -> vc -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorAppendAndSelectValue f h k vc = - mapCursorNonEmptyCursorL %~ - nonEmptyCursorAppendAndSelect (rebuild f h) (makeKeyValueCursorValue k vc) + mapCursorNonEmptyCursorL + %~ nonEmptyCursorAppendAndSelect (rebuild f h) (makeKeyValueCursorValue k vc) mapCursorRemoveElemAndSelectPrev :: - (k -> kc) -> MapCursor kc vc k v -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) + (k -> kc) -> MapCursor kc vc k v -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) mapCursorRemoveElemAndSelectPrev g = focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ - nonEmptyCursorRemoveElemAndSelectPrev (make g) + nonEmptyCursorRemoveElemAndSelectPrev (make g) mapCursorDeleteElemAndSelectNext :: - (k -> kc) -> MapCursor kc vc k v -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) + (k -> kc) -> MapCursor kc vc k v -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) mapCursorDeleteElemAndSelectNext g = focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ - nonEmptyCursorDeleteElemAndSelectNext (make g) + nonEmptyCursorDeleteElemAndSelectNext (make g) mapCursorRemoveElem :: (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) mapCursorRemoveElem g = mapCursorNonEmptyCursorL $ nonEmptyCursorRemoveElem (make g) @@ -189,26 +202,26 @@ mapCursorDeleteElem g = mapCursorNonEmptyCursorL $ nonEmptyCursorDeleteElem (make g) mapCursorSearch :: - (kc -> k) - -> (k -> kc) - -> (vc -> v) - -> (k -> v -> Bool) - -> MapCursor kc vc k v - -> Maybe (MapCursor kc vc k v) + (kc -> k) -> + (k -> kc) -> + (vc -> v) -> + (k -> v -> Bool) -> + MapCursor kc vc k v -> + Maybe (MapCursor kc vc k v) mapCursorSearch f g h p = mapCursorNonEmptyCursorL $ nonEmptyCursorSearch (rebuild f h) (make g) (uncurry p . rebuild f h) mapCursorSelectOrAdd :: - (kc -> k) - -> (k -> kc) - -> (vc -> v) - -> (k -> v -> Bool) - -> KeyValueCursor kc vc k v - -> MapCursor kc vc k v - -> MapCursor kc vc k v + (kc -> k) -> + (k -> kc) -> + (vc -> v) -> + (k -> v -> Bool) -> + KeyValueCursor kc vc k v -> + MapCursor kc vc k v -> + MapCursor kc vc k v mapCursorSelectOrAdd f g h p kvc = - mapCursorNonEmptyCursorL %~ - nonEmptyCursorSelectOrAdd (rebuild f h) (make g) (uncurry p . rebuild f h) kvc + mapCursorNonEmptyCursorL + %~ nonEmptyCursorSelectOrAdd (rebuild f h) (make g) (uncurry p . rebuild f h) kvc rebuild :: (kc -> k) -> (vc -> v) -> KeyValueCursor kc vc k v -> (k, v) rebuild = rebuildKeyValueCursor @@ -217,8 +230,16 @@ make g (k, v) = makeKeyValueCursorKey (g k) v traverseMapCursor :: - ([(k, v)] -> KeyValueCursor kc vc k v -> [(k, v)] -> f c) -> MapCursor kc vc k v -> f c + ([(k, v)] -> KeyValueCursor kc vc k v -> [(k, v)] -> f c) -> MapCursor kc vc k v -> f c traverseMapCursor combFunc = foldNonEmptyCursor combFunc . mapCursorList + +mapCursorTraverseKeyCase :: + Applicative f => (kc -> v -> f (kc', v)) -> MapCursor kc vc k v -> f (MapCursor kc' vc k v) +mapCursorTraverseKeyCase func = mapCursorElemL $ keyValueCursorTraverseKeyCase func + +mapCursorTraverseValueCase :: + Applicative f => (k -> vc -> f (k, vc')) -> MapCursor kc vc k v -> f (MapCursor kc vc' k v) +mapCursorTraverseValueCase func = mapCursorElemL $ keyValueCursorTraverseValueCase func foldMapCursor :: ([(k, v)] -> KeyValueCursor kc vc k v -> [(k, v)] -> c) -> MapCursor kc vc k v -> c foldMapCursor combFunc = foldNonEmptyCursor combFunc . mapCursorList diff --git a/src/Cursor/Map/KeyValue.hs b/src/Cursor/Map/KeyValue.hs --- a/src/Cursor/Map/KeyValue.hs +++ b/src/Cursor/Map/KeyValue.hs @@ -1,35 +1,38 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Cursor.Map.KeyValue - ( KeyValueCursor(..) - , makeKeyValueCursorKey - , makeKeyValueCursorValue - , rebuildKeyValueCursor - , keyValueCursorSelection - , mapKeyValueCursor - , keyValueCursorSelectKey - , keyValueCursorSelectValue - , keyValueCursorToggleSelected - , KeyValueToggle(..) - , traverseKeyValueCursor - , foldKeyValueCursor - ) where - -import GHC.Generics (Generic) - -import Data.Validity + ( KeyValueCursor (..), + makeKeyValueCursorKey, + makeKeyValueCursorValue, + rebuildKeyValueCursor, + keyValueCursorSelection, + mapKeyValueCursor, + keyValueCursorSelectKey, + keyValueCursorSelectValue, + keyValueCursorToggleSelected, + KeyValueToggle (..), + traverseKeyValueCursor, + keyValueCursorTraverseKeyCase, + keyValueCursorTraverseValueCase, + foldKeyValueCursor, + ) +where import Control.DeepSeq +import Data.Validity +import GHC.Generics (Generic) data KeyValueCursor kc vc k v = KeyValueCursorKey kc v | KeyValueCursorValue k vc deriving (Show, Eq, Generic) -instance (Validity kc, Validity vc, Validity k, Validity v) => - Validity (KeyValueCursor kc vc k v) +instance + (Validity kc, Validity vc, Validity k, Validity v) => + Validity (KeyValueCursor kc vc k v) instance (NFData kc, NFData vc, NFData k, NFData v) => NFData (KeyValueCursor kc vc k v) @@ -48,38 +51,38 @@ keyValueCursorSelection (KeyValueCursorValue _ _) = ValueSelected mapKeyValueCursor :: - (kc -> lc) - -> (vc -> wc) - -> (k -> l) - -> (v -> w) - -> KeyValueCursor kc vc k v - -> KeyValueCursor lc wc l w + (kc -> lc) -> + (vc -> wc) -> + (k -> l) -> + (v -> w) -> + KeyValueCursor kc vc k v -> + KeyValueCursor lc wc l w mapKeyValueCursor a b c d kvc = case kvc of KeyValueCursorKey kc v -> KeyValueCursorKey (a kc) (d v) KeyValueCursorValue k vc -> KeyValueCursorValue (c k) (b vc) keyValueCursorSelectKey :: - (k -> kc) -> (vc -> v) -> KeyValueCursor kc vc k v -> KeyValueCursor kc vc k v + (k -> kc) -> (vc -> v) -> KeyValueCursor kc vc k v -> KeyValueCursor kc vc k v keyValueCursorSelectKey g h kvc = case kvc of KeyValueCursorValue k vc -> KeyValueCursorKey (g k) (h vc) _ -> kvc keyValueCursorSelectValue :: - (kc -> k) -> (v -> vc) -> KeyValueCursor kc vc k v -> KeyValueCursor kc vc k v + (kc -> k) -> (v -> vc) -> KeyValueCursor kc vc k v -> KeyValueCursor kc vc k v keyValueCursorSelectValue f i kvc = case kvc of KeyValueCursorKey kc v -> KeyValueCursorValue (f kc) (i v) _ -> kvc keyValueCursorToggleSelected :: - (kc -> k) - -> (k -> kc) - -> (vc -> v) - -> (v -> vc) - -> KeyValueCursor kc vc k v - -> KeyValueCursor kc vc k v + (kc -> k) -> + (k -> kc) -> + (vc -> v) -> + (v -> vc) -> + KeyValueCursor kc vc k v -> + KeyValueCursor kc vc k v keyValueCursorToggleSelected f g h i kvc = case kvc of KeyValueCursorKey kc v -> KeyValueCursorValue (f kc) (i v) @@ -94,6 +97,26 @@ traverseKeyValueCursor :: (kc -> v -> f c) -> (k -> vc -> f c) -> KeyValueCursor kc vc k v -> f c traverseKeyValueCursor = foldKeyValueCursor + +keyValueCursorTraverseKeyCase :: + Applicative f => + (kc -> v -> f (kc', v')) -> + KeyValueCursor kc vc k v -> + f (KeyValueCursor kc' vc k v') +keyValueCursorTraverseKeyCase func = + \case + KeyValueCursorKey kc v -> uncurry KeyValueCursorKey <$> func kc v + KeyValueCursorValue k vc -> pure (KeyValueCursorValue k vc) + +keyValueCursorTraverseValueCase :: + Applicative f => + (k -> vc -> f (k', vc')) -> + KeyValueCursor kc vc k v -> + f (KeyValueCursor kc vc' k' v) +keyValueCursorTraverseValueCase func = + \case + KeyValueCursorKey kc v -> pure (KeyValueCursorKey kc v) + KeyValueCursorValue k vc -> uncurry KeyValueCursorValue <$> func k vc foldKeyValueCursor :: (kc -> v -> c) -> (k -> vc -> c) -> KeyValueCursor kc vc k v -> c foldKeyValueCursor keyFunc valFunc kvc = diff --git a/src/Cursor/Simple/Forest.hs b/src/Cursor/Simple/Forest.hs --- a/src/Cursor/Simple/Forest.hs +++ b/src/Cursor/Simple/Forest.hs @@ -1,87 +1,105 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.Forest - ( ForestCursor - , makeForestCursor - , rebuildForestCursor - , FC.drawForestCursor - , mapForestCursor - , FC.forestCursorListCursorL - , FC.forestCursorSelectedTreeL - , forestCursorSelectPrevTreeCursor - , forestCursorSelectNextTreeCursor - , forestCursorSelectFirstTreeCursor - , forestCursorSelectLastTreeCursor - , forestCursorSelectPrev - , forestCursorSelectNext - , forestCursorSelectPrevOnSameLevel - , forestCursorSelectNextOnSameLevel - , forestCursorSelectFirst - , forestCursorSelectLast - , forestCursorSelectAbove - , forestCursorSelectBelowAtPos - , forestCursorSelectBelowAtStart - , forestCursorSelectBelowAtEnd - , FC.forestCursorOpenCurrentForest - , FC.forestCursorCloseCurrentForest - , FC.forestCursorToggleCurrentForest - , FC.forestCursorOpenCurrentForestRecursively - , FC.forestCursorToggleCurrentForestRecursively - , FC.forestCursorSelection - , forestCursorSelectIndex - , FC.forestCursorInsertEntireTree - , forestCursorInsertAndSelectTreeCursor - , FC.forestCursorAppendEntireTree - , forestCursorAppendAndSelectTreeCursor - , FC.forestCursorInsertTree - , FC.forestCursorAppendTree - , forestCursorInsertAndSelectTree - , forestCursorAppendAndSelectTree - , FC.forestCursorInsert - , FC.forestCursorAppend - , forestCursorInsertAndSelect - , forestCursorAppendAndSelect - , FC.forestCursorAddChildTreeToNodeAtPos - , FC.forestCursorAddChildTreeToNodeAtStart - , FC.forestCursorAddChildTreeToNodeAtEnd - , FC.forestCursorAddChildToNodeAtPos - , FC.forestCursorAddChildToNodeAtStart - , FC.forestCursorAddChildToNodeAtEnd - , forestCursorRemoveElemAndSelectPrev - , forestCursorDeleteElemAndSelectNext - , forestCursorRemoveElem - , forestCursorDeleteElem - , forestCursorRemoveSubTreeAndSelectPrev - , forestCursorDeleteSubTreeAndSelectNext - , forestCursorRemoveSubTree - , forestCursorDeleteSubTree - , forestCursorAddRoot - , FC.forestCursorSwapPrev - , FC.forestCursorSwapNext - , forestCursorPromoteElem - , forestCursorPromoteSubTree - , forestCursorDemoteElem - , forestCursorDemoteSubTree - , FC.forestCursorDemoteElemUnder - , FC.forestCursorDemoteSubTreeUnder - , FC.CTree(..) - , FC.makeCTree - , FC.cTree - , FC.rebuildCTree - , FC.CForest(..) - , FC.makeCForest - , FC.cForest - , FC.rebuildCForest - ) where - -import Data.Validity.Tree () - -import Data.List.NonEmpty (NonEmpty) -import Data.Tree + ( ForestCursor, + FC.singletonForestCursor, + makeForestCursor, + rebuildForestCursor, + FC.drawForestCursor, + mapForestCursor, + FC.forestCursorListCursorL, + FC.forestCursorSelectedTreeL, + forestCursorSelectPrevTreeCursor, + forestCursorSelectNextTreeCursor, + forestCursorSelectFirstTreeCursor, + forestCursorSelectLastTreeCursor, + forestCursorSelectPrev, + forestCursorSelectNext, + forestCursorSelectPrevOnSameLevel, + forestCursorSelectNextOnSameLevel, + forestCursorSelectFirst, + forestCursorSelectLast, + forestCursorSelectFirstOnSameLevel, + forestCursorSelectLastOnSameLevel, + forestCursorSelectAbove, + forestCursorSelectBelowAtPos, + forestCursorSelectBelowAtStart, + forestCursorSelectBelowAtEnd, + FC.forestCursorOpenCurrentForest, + FC.forestCursorCloseCurrentForest, + FC.forestCursorToggleCurrentForest, + FC.forestCursorOpenCurrentForestRecursively, + FC.forestCursorToggleCurrentForestRecursively, + FC.forestCursorSelection, + forestCursorSelectIndex, + FC.forestCursorInsertEntireTree, + forestCursorInsertAndSelectTreeCursor, + FC.forestCursorAppendEntireTree, + forestCursorAppendAndSelectTreeCursor, + FC.forestCursorInsertTree, + FC.forestCursorAppendTree, + forestCursorInsertAndSelectTree, + forestCursorAppendAndSelectTree, + FC.forestCursorInsert, + FC.forestCursorAppend, + forestCursorInsertAndSelect, + forestCursorAppendAndSelect, + forestCursorInsertNodeSingleAndSelect, + forestCursorAppendNodeSingleAndSelect, + forestCursorInsertNodeAndSelect, + forestCursorAppendNodeAndSelect, + FC.forestCursorAddChildTreeToNodeAtPos, + FC.forestCursorAddChildTreeToNodeAtStart, + FC.forestCursorAddChildTreeToNodeAtEnd, + FC.forestCursorAddChildToNodeAtPos, + FC.forestCursorAddChildToNodeAtStart, + FC.forestCursorAddChildToNodeAtEnd, + forestCursorAddChildTreeToNodeAtPosAndSelect, + forestCursorAddChildTreeToNodeAtStartAndSelect, + forestCursorAddChildTreeToNodeAtEndAndSelect, + forestCursorAddChildToNodeAtPosAndSelect, + forestCursorAddChildToNodeAtStartAndSelect, + forestCursorAddChildToNodeAtEndAndSelect, + forestCursorAddChildNodeSingleToNodeAtPosAndSelect, + forestCursorAddChildNodeSingleToNodeAtStartAndSelect, + forestCursorAddChildNodeSingleToNodeAtEndAndSelect, + forestCursorAddChildNodeToNodeAtPosAndSelect, + forestCursorAddChildNodeToNodeAtStartAndSelect, + forestCursorAddChildNodeToNodeAtEndAndSelect, + forestCursorRemoveElemAndSelectPrev, + forestCursorDeleteElemAndSelectNext, + forestCursorRemoveElem, + forestCursorDeleteElem, + forestCursorRemoveSubTreeAndSelectPrev, + forestCursorDeleteSubTreeAndSelectNext, + forestCursorRemoveSubTree, + forestCursorDeleteSubTree, + forestCursorAddRoot, + FC.forestCursorSwapPrev, + FC.forestCursorSwapNext, + forestCursorPromoteElem, + forestCursorPromoteSubTree, + forestCursorDemoteElem, + forestCursorDemoteSubTree, + FC.forestCursorDemoteElemUnder, + FC.forestCursorDemoteSubTreeUnder, + FC.CTree (..), + FC.makeCTree, + FC.cTree, + FC.rebuildCTree, + FC.CForest (..), + FC.makeCForest, + FC.cForest, + FC.rebuildCForest, + ) +where import qualified Cursor.Forest as FC import Cursor.Simple.Tree import Cursor.Types +import Data.List.NonEmpty (NonEmpty) +import Data.Tree +import Data.Validity.Tree () type ForestCursor a = FC.ForestCursor a a @@ -124,6 +142,12 @@ forestCursorSelectLast :: ForestCursor a -> ForestCursor a forestCursorSelectLast = FC.forestCursorSelectLast id id +forestCursorSelectFirstOnSameLevel :: ForestCursor a -> ForestCursor a +forestCursorSelectFirstOnSameLevel = FC.forestCursorSelectFirstOnSameLevel id id + +forestCursorSelectLastOnSameLevel :: ForestCursor a -> ForestCursor a +forestCursorSelectLastOnSameLevel = FC.forestCursorSelectLastOnSameLevel id id + forestCursorSelectAbove :: ForestCursor a -> Maybe (ForestCursor a) forestCursorSelectAbove = FC.forestCursorSelectAbove id id @@ -154,8 +178,57 @@ forestCursorInsertAndSelect :: a -> ForestCursor a -> ForestCursor a forestCursorInsertAndSelect = FC.forestCursorInsertAndSelect id id +forestCursorInsertNodeSingleAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorInsertNodeSingleAndSelect = FC.forestCursorInsertNodeSingleAndSelect id + +forestCursorInsertNodeAndSelect :: a -> CForest a -> ForestCursor a -> ForestCursor a +forestCursorInsertNodeAndSelect = FC.forestCursorInsertNodeAndSelect id + forestCursorAppendAndSelect :: a -> ForestCursor a -> ForestCursor a forestCursorAppendAndSelect = FC.forestCursorAppendAndSelect id id + +forestCursorAppendNodeSingleAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAppendNodeSingleAndSelect = FC.forestCursorAppendNodeSingleAndSelect id + +forestCursorAppendNodeAndSelect :: a -> CForest a -> ForestCursor a -> ForestCursor a +forestCursorAppendNodeAndSelect = FC.forestCursorAppendNodeAndSelect id + +forestCursorAddChildTreeToNodeAtPosAndSelect :: Int -> Tree a -> ForestCursor a -> ForestCursor a +forestCursorAddChildTreeToNodeAtPosAndSelect = FC.forestCursorAddChildTreeToNodeAtPosAndSelect id id + +forestCursorAddChildTreeToNodeAtStartAndSelect :: Tree a -> ForestCursor a -> ForestCursor a +forestCursorAddChildTreeToNodeAtStartAndSelect = + FC.forestCursorAddChildTreeToNodeAtStartAndSelect id id + +forestCursorAddChildTreeToNodeAtEndAndSelect :: Tree a -> ForestCursor a -> ForestCursor a +forestCursorAddChildTreeToNodeAtEndAndSelect = FC.forestCursorAddChildTreeToNodeAtEndAndSelect id id + +forestCursorAddChildToNodeAtPosAndSelect :: Int -> a -> ForestCursor a -> ForestCursor a +forestCursorAddChildToNodeAtPosAndSelect = FC.forestCursorAddChildToNodeAtPosAndSelect id id + +forestCursorAddChildToNodeAtStartAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAddChildToNodeAtStartAndSelect = FC.forestCursorAddChildToNodeAtStartAndSelect id id + +forestCursorAddChildToNodeAtEndAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAddChildToNodeAtEndAndSelect = FC.forestCursorAddChildToNodeAtEndAndSelect id id + +forestCursorAddChildNodeSingleToNodeAtPosAndSelect :: Int -> a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeSingleToNodeAtPosAndSelect = FC.forestCursorAddChildNodeSingleToNodeAtPosAndSelect id + +forestCursorAddChildNodeSingleToNodeAtStartAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeSingleToNodeAtStartAndSelect = FC.forestCursorAddChildNodeSingleToNodeAtStartAndSelect id + +forestCursorAddChildNodeSingleToNodeAtEndAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeSingleToNodeAtEndAndSelect = FC.forestCursorAddChildNodeSingleToNodeAtEndAndSelect id + +forestCursorAddChildNodeToNodeAtPosAndSelect :: Int -> a -> Forest a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeToNodeAtPosAndSelect = FC.forestCursorAddChildNodeToNodeAtPosAndSelect id + +forestCursorAddChildNodeToNodeAtStartAndSelect :: a -> Forest a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeToNodeAtStartAndSelect = FC.forestCursorAddChildNodeToNodeAtStartAndSelect id + +forestCursorAddChildNodeToNodeAtEndAndSelect :: a -> Forest a -> ForestCursor a -> ForestCursor a +forestCursorAddChildNodeToNodeAtEndAndSelect = FC.forestCursorAddChildNodeToNodeAtEndAndSelect id forestCursorRemoveElemAndSelectPrev :: ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) forestCursorRemoveElemAndSelectPrev = FC.forestCursorRemoveElemAndSelectPrev id diff --git a/src/Cursor/Simple/List/NonEmpty.hs b/src/Cursor/Simple/List/NonEmpty.hs --- a/src/Cursor/Simple/List/NonEmpty.hs +++ b/src/Cursor/Simple/List/NonEmpty.hs @@ -1,43 +1,42 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.List.NonEmpty - ( NonEmptyCursor - , NEC.nonEmptyCursorPrev - , NEC.nonEmptyCursorCurrent - , NEC.nonEmptyCursorNext - , makeNonEmptyCursor - , makeNonEmptyCursorWithSelection - , NEC.singletonNonEmptyCursor - , rebuildNonEmptyCursor - , mapNonEmptyCursor - , NEC.nonEmptyCursorElemL - , nonEmptyCursorSelectPrev - , nonEmptyCursorSelectNext - , nonEmptyCursorSelectFirst - , nonEmptyCursorSelectLast - , NEC.nonEmptyCursorSelection - , nonEmptyCursorSelectIndex - , NEC.nonEmptyCursorInsert - , NEC.nonEmptyCursorAppend - , nonEmptyCursorInsertAndSelect - , nonEmptyCursorAppendAndSelect - , NEC.nonEmptyCursorInsertAtStart - , NEC.nonEmptyCursorAppendAtEnd - , nonEmptyCursorInsertAtStartAndSelect - , nonEmptyCursorAppendAtEndAndSelect - , nonEmptyCursorRemoveElemAndSelectPrev - , nonEmptyCursorDeleteElemAndSelectNext - , nonEmptyCursorRemoveElem - , nonEmptyCursorDeleteElem - , nonEmptyCursorSearch - , nonEmptyCursorSelectOrAdd - ) where - -import Data.List.NonEmpty (NonEmpty(..)) - -import Cursor.Types + ( NonEmptyCursor, + NEC.nonEmptyCursorPrev, + NEC.nonEmptyCursorCurrent, + NEC.nonEmptyCursorNext, + makeNonEmptyCursor, + makeNonEmptyCursorWithSelection, + NEC.singletonNonEmptyCursor, + rebuildNonEmptyCursor, + mapNonEmptyCursor, + NEC.nonEmptyCursorElemL, + nonEmptyCursorSelectPrev, + nonEmptyCursorSelectNext, + nonEmptyCursorSelectFirst, + nonEmptyCursorSelectLast, + NEC.nonEmptyCursorSelection, + nonEmptyCursorSelectIndex, + NEC.nonEmptyCursorInsert, + NEC.nonEmptyCursorAppend, + nonEmptyCursorInsertAndSelect, + nonEmptyCursorAppendAndSelect, + NEC.nonEmptyCursorInsertAtStart, + NEC.nonEmptyCursorAppendAtEnd, + nonEmptyCursorInsertAtStartAndSelect, + nonEmptyCursorAppendAtEndAndSelect, + nonEmptyCursorRemoveElemAndSelectPrev, + nonEmptyCursorDeleteElemAndSelectNext, + nonEmptyCursorRemoveElem, + nonEmptyCursorDeleteElem, + nonEmptyCursorSearch, + nonEmptyCursorSelectOrAdd, + ) +where import qualified Cursor.List.NonEmpty as NEC +import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..)) -- | A 'nonempty list' cursor type NonEmptyCursor a = NEC.NonEmptyCursor a a @@ -82,11 +81,11 @@ nonEmptyCursorAppendAtEndAndSelect = NEC.nonEmptyCursorAppendAtEndAndSelect id id nonEmptyCursorRemoveElemAndSelectPrev :: - NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) nonEmptyCursorRemoveElemAndSelectPrev = NEC.nonEmptyCursorRemoveElemAndSelectPrev id nonEmptyCursorDeleteElemAndSelectNext :: - NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) nonEmptyCursorDeleteElemAndSelectNext = NEC.nonEmptyCursorDeleteElemAndSelectNext id nonEmptyCursorRemoveElem :: NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) diff --git a/src/Cursor/Simple/Map.hs b/src/Cursor/Simple/Map.hs --- a/src/Cursor/Simple/Map.hs +++ b/src/Cursor/Simple/Map.hs @@ -2,45 +2,45 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.Map - ( MapCursor - , MC.mapCursorList - , makeMapCursor - , makeMapCursorWithSelection - , MC.singletonMapCursorKey - , MC.singletonMapCursorValue - , rebuildMapCursor - , mapMapCursor - , MC.mapCursorNonEmptyCursorL - , MC.mapCursorElemL - , mapCursorSelectKey - , mapCursorSelectValue - , mapCursorToggleSelected - , mapCursorSelectPrev - , mapCursorSelectNext - , mapCursorSelectFirst - , mapCursorSelectLast - , MC.mapCursorSelection - , mapCursorSelectIndex - , MC.mapCursorInsert - , MC.mapCursorAppend - , mapCursorInsertAndSelectKey - , mapCursorAppendAndSelectKey - , mapCursorInsertAndSelectValue - , mapCursorAppendAndSelectValue - , mapCursorRemoveElemAndSelectPrev - , mapCursorDeleteElemAndSelectNext - , mapCursorRemoveElem - , mapCursorDeleteElem - , mapCursorSearch - , mapCursorSelectOrAdd - , module Cursor.Simple.Map.KeyValue - ) where - -import Data.List.NonEmpty (NonEmpty(..)) + ( MapCursor, + MC.mapCursorList, + makeMapCursor, + makeMapCursorWithSelection, + MC.singletonMapCursorKey, + MC.singletonMapCursorValue, + rebuildMapCursor, + mapMapCursor, + MC.mapCursorNonEmptyCursorL, + MC.mapCursorElemL, + mapCursorSelectKey, + mapCursorSelectValue, + mapCursorToggleSelected, + mapCursorSelectPrev, + mapCursorSelectNext, + mapCursorSelectFirst, + mapCursorSelectLast, + MC.mapCursorSelection, + mapCursorSelectIndex, + MC.mapCursorInsert, + MC.mapCursorAppend, + mapCursorInsertAndSelectKey, + mapCursorAppendAndSelectKey, + mapCursorInsertAndSelectValue, + mapCursorAppendAndSelectValue, + mapCursorRemoveElemAndSelectPrev, + mapCursorDeleteElemAndSelectNext, + mapCursorRemoveElem, + mapCursorDeleteElem, + mapCursorSearch, + mapCursorSelectOrAdd, + module Cursor.Simple.Map.KeyValue, + ) +where import qualified Cursor.Map as MC import Cursor.Simple.Map.KeyValue import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..)) type MapCursor k v = MC.MapCursor k v k v diff --git a/src/Cursor/Simple/Map/KeyValue.hs b/src/Cursor/Simple/Map/KeyValue.hs --- a/src/Cursor/Simple/Map/KeyValue.hs +++ b/src/Cursor/Simple/Map/KeyValue.hs @@ -1,19 +1,20 @@ {-# LANGUAGE PatternSynonyms #-} module Cursor.Simple.Map.KeyValue - ( KeyValueCursor - , pattern KVC.KeyValueCursorKey - , pattern KVC.KeyValueCursorValue - , KVC.makeKeyValueCursorKey - , KVC.makeKeyValueCursorValue - , rebuildKeyValueCursor - , KVC.keyValueCursorSelection - , mapKeyValueCursor - , keyValueCursorSelectKey - , keyValueCursorSelectValue - , keyValueCursorToggleSelected - , KVC.KeyValueToggle(..) - ) where + ( KeyValueCursor, + pattern KVC.KeyValueCursorKey, + pattern KVC.KeyValueCursorValue, + KVC.makeKeyValueCursorKey, + KVC.makeKeyValueCursorValue, + rebuildKeyValueCursor, + KVC.keyValueCursorSelection, + mapKeyValueCursor, + keyValueCursorSelectKey, + keyValueCursorSelectValue, + keyValueCursorToggleSelected, + KVC.KeyValueToggle (..), + ) +where import qualified Cursor.Map.KeyValue as KVC diff --git a/src/Cursor/Simple/Tree.hs b/src/Cursor/Simple/Tree.hs --- a/src/Cursor/Simple/Tree.hs +++ b/src/Cursor/Simple/Tree.hs @@ -1,86 +1,101 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Simple.Tree - ( TreeCursor - , TreeAbove(..) - , singletonTreeCursor - , makeTreeCursor - , makeTreeCursorWithSelection - , rebuildTreeCursor - , TC.drawTreeCursor - , mapTreeCursor - , TC.treeCursorAboveL - , TC.treeCursorCurrentL - , TC.treeCursorBelowL - , TC.treeAboveLeftsL - , TC.treeAboveAboveL - , TC.treeAboveNodeL - , TC.treeAboveRightsL - , TC.treeCursorWithPointer - , TC.treeCursorSelection - , TC.TreeCursorSelection(..) - , treeCursorSelect - , treeCursorSelectPrev - , treeCursorSelectNext - , treeCursorSelectFirst - , treeCursorSelectLast - , treeCursorSelectAbove - , treeCursorSelectBelowAtPos - , treeCursorSelectBelowAtStart - , treeCursorSelectBelowAtEnd - , treeCursorSelectBelowAtStartRecursively - , treeCursorSelectBelowAtEndRecursively - , treeCursorSelectPrevOnSameLevel - , treeCursorSelectNextOnSameLevel - , treeCursorSelectAbovePrev - , treeCursorSelectAboveNext - , TC.treeCursorOpenCurrentForest - , TC.treeCursorCloseCurrentForest - , TC.treeCursorToggleCurrentForest - , TC.treeCursorOpenCurrentForestRecursively - , TC.treeCursorToggleCurrentForestRecursively - , TC.treeCursorInsert - , treeCursorInsertAndSelect - , TC.treeCursorAppend - , treeCursorAppendAndSelect - , TC.treeCursorAddChildAtPos - , TC.treeCursorAddChildAtStart - , TC.treeCursorAddChildAtEnd - , treeCursorDeleteSubTreeAndSelectPrevious - , treeCursorDeleteSubTreeAndSelectNext - , treeCursorDeleteSubTreeAndSelectAbove - , treeCursorRemoveSubTree - , treeCursorDeleteSubTree - , treeCursorDeleteElemAndSelectPrevious - , treeCursorDeleteElemAndSelectNext - , treeCursorDeleteElemAndSelectAbove - , treeCursorRemoveElem - , treeCursorDeleteElem - , TC.treeCursorSwapPrev - , TC.treeCursorSwapNext - , TC.SwapResult(..) - , treeCursorPromoteElem - , TC.PromoteElemResult(..) - , treeCursorPromoteSubTree - , TC.PromoteResult(..) - , treeCursorDemoteElem - , treeCursorDemoteSubTree - , TC.DemoteResult(..) - , TC.treeCursorDemoteElemUnder - , TC.treeCursorDemoteSubTreeUnder - , TC.CTree(..) - , TC.CForest - , TC.makeCTree - , TC.cTree - , TC.rebuildCTree - ) where - -import Data.Tree - -import Cursor.Types + ( TreeCursor, + TreeAbove (..), + singletonTreeCursor, + makeTreeCursor, + TC.makeNodeTreeCursor, + makeTreeCursorWithSelection, + rebuildTreeCursor, + TC.drawTreeCursor, + mapTreeCursor, + TC.treeCursorAboveL, + TC.treeCursorCurrentL, + TC.treeCursorBelowL, + TC.treeAboveLeftsL, + TC.treeAboveAboveL, + TC.treeAboveNodeL, + TC.treeAboveRightsL, + TC.treeCursorWithPointer, + TC.treeCursorSelection, + TC.TreeCursorSelection (..), + treeCursorSelect, + treeCursorSelectPrev, + treeCursorSelectNext, + treeCursorSelectFirst, + treeCursorSelectLast, + treeCursorSelectAbove, + treeCursorSelectBelowAtPos, + treeCursorSelectBelowAtStart, + treeCursorSelectBelowAtEnd, + treeCursorSelectBelowAtStartRecursively, + treeCursorSelectBelowAtEndRecursively, + treeCursorSelectPrevOnSameLevel, + treeCursorSelectNextOnSameLevel, + treeCursorSelectFirstOnSameLevel, + treeCursorSelectLastOnSameLevel, + treeCursorSelectAbovePrev, + treeCursorSelectAboveNext, + TC.treeCursorOpenCurrentForest, + TC.treeCursorCloseCurrentForest, + TC.treeCursorToggleCurrentForest, + TC.treeCursorOpenCurrentForestRecursively, + TC.treeCursorToggleCurrentForestRecursively, + TC.treeCursorInsert, + treeCursorInsertAndSelect, + treeCursorInsertNodeSingleAndSelect, + treeCursorInsertNodeAndSelect, + TC.treeCursorAppend, + treeCursorAppendAndSelect, + treeCursorAppendNodeSingleAndSelect, + treeCursorAppendNodeAndSelect, + TC.treeCursorAddChildAtPos, + TC.treeCursorAddChildAtStart, + TC.treeCursorAddChildAtEnd, + treeCursorAddChildAtPosAndSelect, + treeCursorAddChildAtStartAndSelect, + treeCursorAddChildAtEndAndSelect, + treeCursorAddChildNodeSingleAtPosAndSelect, + treeCursorAddChildNodeSingleAtStartAndSelect, + treeCursorAddChildNodeSingleAtEndAndSelect, + treeCursorAddChildNodeAtPosAndSelect, + treeCursorAddChildNodeAtStartAndSelect, + treeCursorAddChildNodeAtEndAndSelect, + treeCursorDeleteSubTreeAndSelectPrevious, + treeCursorDeleteSubTreeAndSelectNext, + treeCursorDeleteSubTreeAndSelectAbove, + treeCursorRemoveSubTree, + treeCursorDeleteSubTree, + treeCursorDeleteElemAndSelectPrevious, + treeCursorDeleteElemAndSelectNext, + treeCursorDeleteElemAndSelectAbove, + treeCursorRemoveElem, + treeCursorDeleteElem, + TC.treeCursorSwapPrev, + TC.treeCursorSwapNext, + TC.SwapResult (..), + treeCursorPromoteElem, + TC.PromoteElemResult (..), + treeCursorPromoteSubTree, + TC.PromoteResult (..), + treeCursorDemoteElem, + treeCursorDemoteSubTree, + TC.DemoteResult (..), + TC.treeCursorDemoteElemUnder, + TC.treeCursorDemoteSubTreeUnder, + TC.CTree (..), + TC.CForest, + TC.makeCTree, + TC.cTree, + TC.rebuildCTree, + ) +where +import Cursor.Tree (CForest (..), CTree, TreeAbove (..)) import qualified Cursor.Tree as TC -import Cursor.Tree (CTree, TreeAbove(..)) +import Cursor.Types +import Data.Tree type TreeCursor a = TC.TreeCursor a a @@ -138,6 +153,12 @@ treeCursorSelectNextOnSameLevel :: TreeCursor a -> Maybe (TreeCursor a) treeCursorSelectNextOnSameLevel = TC.treeCursorSelectNextOnSameLevel id id +treeCursorSelectFirstOnSameLevel :: TreeCursor a -> TreeCursor a +treeCursorSelectFirstOnSameLevel = TC.treeCursorSelectFirstOnSameLevel id id + +treeCursorSelectLastOnSameLevel :: TreeCursor a -> TreeCursor a +treeCursorSelectLastOnSameLevel = TC.treeCursorSelectLastOnSameLevel id id + -- | Go back and down as far as necessary to find a previous element on a level below treeCursorSelectAbovePrev :: TreeCursor a -> Maybe (TreeCursor a) treeCursorSelectAbovePrev = TC.treeCursorSelectAbovePrev id id @@ -151,8 +172,47 @@ treeCursorInsertAndSelect :: Tree a -> TreeCursor a -> Maybe (TreeCursor a) treeCursorInsertAndSelect = TC.treeCursorInsertAndSelect id id +treeCursorInsertNodeSingleAndSelect :: a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorInsertNodeSingleAndSelect = TC.treeCursorInsertNodeSingleAndSelect id + +treeCursorInsertNodeAndSelect :: a -> CForest a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorInsertNodeAndSelect = TC.treeCursorInsertNodeAndSelect id + treeCursorAppendAndSelect :: Tree a -> TreeCursor a -> Maybe (TreeCursor a) treeCursorAppendAndSelect = TC.treeCursorAppendAndSelect id id + +treeCursorAppendNodeSingleAndSelect :: a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorAppendNodeSingleAndSelect = TC.treeCursorAppendNodeSingleAndSelect id + +treeCursorAppendNodeAndSelect :: a -> CForest a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorAppendNodeAndSelect = TC.treeCursorAppendNodeAndSelect id + +treeCursorAddChildAtPosAndSelect :: Int -> Tree a -> TreeCursor a -> TreeCursor a +treeCursorAddChildAtPosAndSelect = TC.treeCursorAddChildAtPosAndSelect id id + +treeCursorAddChildAtStartAndSelect :: Tree a -> TreeCursor a -> TreeCursor a +treeCursorAddChildAtStartAndSelect = TC.treeCursorAddChildAtStartAndSelect id id + +treeCursorAddChildAtEndAndSelect :: Tree a -> TreeCursor a -> TreeCursor a +treeCursorAddChildAtEndAndSelect = TC.treeCursorAddChildAtEndAndSelect id id + +treeCursorAddChildNodeSingleAtPosAndSelect :: Int -> a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeSingleAtPosAndSelect = TC.treeCursorAddChildNodeSingleAtPosAndSelect id + +treeCursorAddChildNodeSingleAtStartAndSelect :: a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeSingleAtStartAndSelect = TC.treeCursorAddChildNodeSingleAtStartAndSelect id + +treeCursorAddChildNodeSingleAtEndAndSelect :: a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeSingleAtEndAndSelect = TC.treeCursorAddChildNodeSingleAtEndAndSelect id + +treeCursorAddChildNodeAtPosAndSelect :: Int -> a -> Forest a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeAtPosAndSelect = TC.treeCursorAddChildNodeAtPosAndSelect id + +treeCursorAddChildNodeAtStartAndSelect :: a -> Forest a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeAtStartAndSelect = TC.treeCursorAddChildNodeAtStartAndSelect id + +treeCursorAddChildNodeAtEndAndSelect :: a -> Forest a -> TreeCursor a -> TreeCursor a +treeCursorAddChildNodeAtEndAndSelect = TC.treeCursorAddChildNodeAtEndAndSelect id treeCursorDeleteSubTreeAndSelectPrevious :: TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteSubTreeAndSelectPrevious = TC.treeCursorDeleteSubTreeAndSelectPrevious id diff --git a/src/Cursor/Text.hs b/src/Cursor/Text.hs --- a/src/Cursor/Text.hs +++ b/src/Cursor/Text.hs @@ -2,57 +2,62 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Text - ( TextCursor(..) - , emptyTextCursor - , makeTextCursor - , makeTextCursorWithSelection - , rebuildTextCursor - , textCursorNull - , textCursorLength - , textCursorIndex - , textCursorSelectPrev - , textCursorSelectNext - , textCursorSelectIndex - , textCursorSelectStart - , textCursorSelectEnd - , textCursorPrevChar - , textCursorNextChar - , textCursorInsert - , textCursorAppend - , textCursorRemove - , textCursorDelete - , textCursorSplit - , textCursorCombine - ) where - -import Data.Validity -import GHC.Generics (Generic) - -import qualified Data.Text as T -import Data.Text (Text) + ( TextCursor (..), + emptyTextCursor, + makeTextCursor, + makeTextCursorWithSelection, + rebuildTextCursor, + textCursorNull, + textCursorLength, + textCursorIndex, + textCursorSelectPrev, + textCursorSelectNext, + textCursorSelectIndex, + textCursorSelectStart, + textCursorSelectEnd, + textCursorPrevChar, + textCursorNextChar, + textCursorSelectBeginWord, + textCursorSelectEndWord, + textCursorSelectNextWord, + textCursorSelectPrevWord, + textCursorInsert, + textCursorAppend, + textCursorInsertString, + textCursorAppendString, + textCursorInsertText, + textCursorAppendText, + textCursorRemove, + textCursorDelete, + textCursorSplit, + textCursorCombine, + ) +where import Control.DeepSeq - -import Lens.Micro - import Cursor.List import Cursor.Types +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validity +import GHC.Generics (Generic) +import Lens.Micro -- | A cursor for single-line texts -newtype TextCursor = - TextCursor - { textCursorList :: ListCursor Char - } +newtype TextCursor = TextCursor + { textCursorList :: ListCursor Char + } deriving (Show, Eq, Generic) instance Validity TextCursor where validate (TextCursor lc) = mconcat - [ genericValidate lc - , decorateList (rebuildListCursor lc) $ \c -> + [ genericValidate lc, + decorateList (rebuildListCursor lc) $ \c -> mconcat - [ declare "The character is not a newline character" $ c /= '\n' - , declare "The character is a safe character" $ isSafeChar c + [ declare "The character is not a newline character" $ c /= '\n', + declare "The character is a safe character" $ isSafeChar c ] ] @@ -74,7 +79,7 @@ rebuildTextCursor = T.pack . rebuildListCursor . textCursorList textCursorListCursorL :: - Functor f => (ListCursor Char -> f (ListCursor Char)) -> TextCursor -> f TextCursor + Functor f => (ListCursor Char -> f (ListCursor Char)) -> TextCursor -> f TextCursor textCursorListCursorL = lens textCursorList (\tc lc -> tc {textCursorList = lc}) textCursorNull :: TextCursor -> Bool @@ -107,6 +112,80 @@ textCursorNextChar :: TextCursor -> Maybe Char textCursorNextChar = listCursorNextItem . textCursorList +-- | Move to the beginning of the word +-- +-- * @"hell|o"@ -> @"|hello"@ +-- * @"hello | world"@ -> @"|hello world"@ +-- * @"hello |world"@ -> @"hello |world"@ +-- * @"| hello"@ -> @"| hello"@ +textCursorSelectBeginWord :: TextCursor -> TextCursor +textCursorSelectBeginWord tc = + let goLeft = maybe tc textCursorSelectBeginWord (textCursorSelectPrev tc) + in case textCursorPrevChar tc of + Nothing -> tc + Just p + | isSpace p -> case textCursorNextChar tc of + Nothing -> goLeft + Just n + | isSpace n -> goLeft + | otherwise -> tc + | otherwise -> goLeft + +-- | Move to the end of the word +-- +-- * @"hell|o"@ -> @"hello|"@ +-- * @"hello | world"@ -> @"hello world|"@ +-- * @"hello| world"@ -> @"hello| world"@ +-- * @"hello |"@ -> @"hello |"@ +textCursorSelectEndWord :: TextCursor -> TextCursor +textCursorSelectEndWord tc = + let goRight = maybe tc textCursorSelectEndWord (textCursorSelectNext tc) + in case textCursorNextChar tc of + Nothing -> tc + Just p + | isSpace p -> case textCursorPrevChar tc of + Nothing -> goRight + Just n + | isSpace n -> goRight + | otherwise -> tc + | otherwise -> goRight + +-- | Move to the beginning of the next word +-- +-- * @"|hello"@ -> @"hello|"@ +-- * @"hell|o world"@ -> @"hello |world"@ +-- * @"hello| world"@ -> @"hello |world"@ +-- * @"hello |"@ -> @"hello |"@ +textCursorSelectNextWord :: TextCursor -> TextCursor +textCursorSelectNextWord tc = + case (textCursorPrevChar tc, textCursorNextChar tc) of + (_, Nothing) -> tc + (Just p, Just n) -> + case (isSpace p, isSpace n) of + (_, True) -> TextCursor $ listCursorNextUntil (not . isSpace) lc + _ -> textCursorSelectNextWord . TextCursor $ listCursorNextUntil isSpace lc + _ -> textCursorSelectNextWord $ TextCursor $ listCursorNextUntil isSpace lc + where + lc = textCursorList tc + +-- | Move to the end of the previous word +-- +-- * @"hello|"@ -> @"|hello"@ +-- * @"hello w|orld"@ -> @"hello| world"@ +-- * @"hello |world"@ -> @"hello| world"@ +-- * @" h|ello"@ -> @"| hello"@ +textCursorSelectPrevWord :: TextCursor -> TextCursor +textCursorSelectPrevWord tc = + case (textCursorPrevChar tc, textCursorNextChar tc) of + (Nothing, _) -> tc + (Just p, Just n) -> + case (isSpace p, isSpace n) of + (True, _) -> TextCursor $ listCursorPrevUntil (not . isSpace) lc + _ -> textCursorSelectPrevWord . TextCursor $ listCursorPrevUntil isSpace lc + _ -> textCursorSelectPrevWord . TextCursor $ listCursorPrevUntil isSpace lc + where + lc = textCursorList tc + textCursorInsert :: Char -> TextCursor -> Maybe TextCursor textCursorInsert '\n' _ = Nothing textCursorInsert c tc = @@ -120,6 +199,24 @@ if isSafeChar c then Just (tc & textCursorListCursorL %~ listCursorAppend c) else Nothing + +textCursorInsertString :: String -> TextCursor -> Maybe TextCursor +textCursorInsertString s tc = + if any (\c -> c == '\n' || not (isSafeChar c)) s + then Nothing + else Just $ tc & textCursorListCursorL %~ listCursorInsertList s + +textCursorAppendString :: String -> TextCursor -> Maybe TextCursor +textCursorAppendString s tc = + if any (\c -> c == '\n' || not (isSafeChar c)) s + then Nothing + else Just $ tc & textCursorListCursorL %~ listCursorAppendList s + +textCursorInsertText :: Text -> TextCursor -> Maybe TextCursor +textCursorInsertText = textCursorInsertString . T.unpack + +textCursorAppendText :: Text -> TextCursor -> Maybe TextCursor +textCursorAppendText = textCursorAppendString . T.unpack textCursorRemove :: TextCursor -> Maybe (DeleteOrUpdate TextCursor) textCursorRemove = focusPossibleDeleteOrUpdate textCursorListCursorL listCursorRemove diff --git a/src/Cursor/TextField.hs b/src/Cursor/TextField.hs --- a/src/Cursor/TextField.hs +++ b/src/Cursor/TextField.hs @@ -4,67 +4,67 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.TextField - ( TextFieldCursor(..) - , makeTextFieldCursor - , makeTextFieldCursorWithSelection - , rebuildTextFieldCursorLines - , rebuildTextFieldCursor - , emptyTextFieldCursor - , nullTextFieldCursor - , textFieldCursorSelection - , textFieldCursorNonEmptyCursorL - , textFieldCursorSelectedL - , textFieldCursorSelectPrevLine - , textFieldCursorSelectNextLine - , textFieldCursorSelectFirstLine - , textFieldCursorSelectLastLine - , textFieldCursorSelectPrevChar - , textFieldCursorSelectNextChar - , textFieldCursorIndexOnLine - , textFieldCursorSelectIndexOnLine - , textFieldCursorInsertChar - , textFieldCursorAppendChar - , textFieldCursorInsertNewline - , textFieldCursorAppendNewline - , textFieldCursorRemove - , textFieldCursorDelete - , textFieldCursorSelectStartOfLine - , textFieldCursorSelectEndOfLine - ) where - -import GHC.Generics (Generic) - -import Data.Validity -import Data.Validity.Text () - -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe -import qualified Data.Text as T -import Data.Text (Text) + ( TextFieldCursor (..), + makeTextFieldCursor, + makeTextFieldCursorWithSelection, + rebuildTextFieldCursorLines, + rebuildTextFieldCursor, + emptyTextFieldCursor, + nullTextFieldCursor, + textFieldCursorSelection, + textFieldCursorNonEmptyCursorL, + textFieldCursorSelectedL, + textFieldCursorSelectPrevLine, + textFieldCursorSelectNextLine, + textFieldCursorSelectFirstLine, + textFieldCursorSelectLastLine, + textFieldCursorSelectPrevChar, + textFieldCursorSelectNextChar, + textFieldCursorSelectPrevWord, + textFieldCursorSelectNextWord, + textFieldCursorSelectBeginWord, + textFieldCursorSelectEndWord, + textFieldCursorIndexOnLine, + textFieldCursorSelectIndexOnLine, + textFieldCursorInsertChar, + textFieldCursorAppendChar, + textFieldCursorInsertNewline, + textFieldCursorAppendNewline, + textFieldCursorRemove, + textFieldCursorDelete, + textFieldCursorSelectStartOfLine, + textFieldCursorSelectEndOfLine, + ) +where import Control.DeepSeq import Control.Monad - -import Lens.Micro - import Cursor.List.NonEmpty import Cursor.Text import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Validity +import Data.Validity.Text () +import GHC.Generics (Generic) +import Lens.Micro -newtype TextFieldCursor = - TextFieldCursor - { textFieldCursorNonEmpty :: NonEmptyCursor TextCursor Text - } +newtype TextFieldCursor = TextFieldCursor + { textFieldCursorNonEmpty :: NonEmptyCursor TextCursor Text + } deriving (Show, Eq, Generic) instance Validity TextFieldCursor where validate tfc@TextFieldCursor {..} = mconcat - [ genericValidate tfc - , decorate "None of the texts contain newlines" $ - decorateList (NE.toList $ rebuildNonEmptyCursor rebuildTextCursor textFieldCursorNonEmpty) $ \tc -> - declare "The text of this line does not contain any newlines" $ T.all (/= '\n') tc + [ genericValidate tfc, + decorate "None of the texts contain newlines" $ + decorateList (NE.toList $ rebuildNonEmptyCursor rebuildTextCursor textFieldCursorNonEmpty) $ + \tc -> + declare "The text of this line does not contain any newlines" $ T.all (/= '\n') tc ] instance NFData TextFieldCursor @@ -97,8 +97,9 @@ textFieldCursorSelection :: TextFieldCursor -> (Int, Int) textFieldCursorSelection tfc = - ( nonEmptyCursorSelection $ textFieldCursorNonEmpty tfc - , textCursorIndex $ textFieldCursorNonEmpty tfc ^. nonEmptyCursorElemL) + ( nonEmptyCursorSelection $ textFieldCursorNonEmpty tfc, + textCursorIndex $ textFieldCursorNonEmpty tfc ^. nonEmptyCursorElemL + ) textFieldCursorNonEmptyCursorL :: Lens' TextFieldCursor (NonEmptyCursor TextCursor Text) textFieldCursorNonEmptyCursorL = @@ -116,9 +117,9 @@ moveMWhileKeepingSelection $ nonEmptyCursorSelectNext rebuildTextCursor unsafeMakeTextCursor moveMWhileKeepingSelection :: - (NonEmptyCursor TextCursor Text -> Maybe (NonEmptyCursor TextCursor Text)) - -> TextFieldCursor - -> Maybe TextFieldCursor + (NonEmptyCursor TextCursor Text -> Maybe (NonEmptyCursor TextCursor Text)) -> + TextFieldCursor -> + Maybe TextFieldCursor moveMWhileKeepingSelection movement tfc = do let i = textFieldCursorIndexOnLine tfc let tfc' = textFieldCursorSelectIndexOnLine 0 tfc @@ -134,9 +135,9 @@ moveWhileKeepingSelection $ nonEmptyCursorSelectLast rebuildTextCursor unsafeMakeTextCursor moveWhileKeepingSelection :: - (NonEmptyCursor TextCursor Text -> NonEmptyCursor TextCursor Text) - -> TextFieldCursor - -> TextFieldCursor + (NonEmptyCursor TextCursor Text -> NonEmptyCursor TextCursor Text) -> + TextFieldCursor -> + TextFieldCursor moveWhileKeepingSelection movement tfc = let i = textFieldCursorIndexOnLine tfc tfc' = textFieldCursorSelectIndexOnLine 0 tfc @@ -149,6 +150,18 @@ textFieldCursorSelectNextChar :: TextFieldCursor -> Maybe TextFieldCursor textFieldCursorSelectNextChar = textFieldCursorSelectedL textCursorSelectNext +textFieldCursorSelectBeginWord :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectBeginWord = textFieldCursorSelectedL %~ textCursorSelectBeginWord + +textFieldCursorSelectEndWord :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectEndWord = textFieldCursorSelectedL %~ textCursorSelectEndWord + +textFieldCursorSelectPrevWord :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectPrevWord = textFieldCursorSelectedL %~ textCursorSelectPrevWord + +textFieldCursorSelectNextWord :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectNextWord = textFieldCursorSelectedL %~ textCursorSelectNextWord + textFieldCursorIndexOnLine :: TextFieldCursor -> Int textFieldCursorIndexOnLine tfc = textCursorIndex $ tfc ^. textFieldCursorSelectedL @@ -165,8 +178,8 @@ _ | isSafeChar c -> Just $ - fromMaybe emptyTextFieldCursor mtfc & - textFieldCursorSelectedL %~ (fromJust . textCursorInsert c) + fromMaybe emptyTextFieldCursor mtfc + & textFieldCursorSelectedL %~ (fromJust . textCursorInsert c) | otherwise -> Nothing -- | @@ -179,77 +192,83 @@ _ | isSafeChar c -> Just $ - fromMaybe emptyTextFieldCursor mtfc & - textFieldCursorSelectedL %~ (fromJust . textCursorAppend c) + fromMaybe emptyTextFieldCursor mtfc + & textFieldCursorSelectedL %~ (fromJust . textCursorAppend c) | otherwise -> Nothing textFieldCursorInsertNewline :: Maybe TextFieldCursor -> TextFieldCursor textFieldCursorInsertNewline mtfc = let tfc = fromMaybe emptyTextFieldCursor mtfc - in tfc & - textFieldCursorNonEmptyCursorL %~ - (\lec@NonEmptyCursor {..} -> - let (tc1, tc2) = textCursorSplit nonEmptyCursorCurrent - in lec - { nonEmptyCursorPrev = rebuildTextCursor tc1 : nonEmptyCursorPrev - , nonEmptyCursorCurrent = tc2 - }) + in tfc + & textFieldCursorNonEmptyCursorL + %~ ( \lec@NonEmptyCursor {..} -> + let (tc1, tc2) = textCursorSplit nonEmptyCursorCurrent + in lec + { nonEmptyCursorPrev = rebuildTextCursor tc1 : nonEmptyCursorPrev, + nonEmptyCursorCurrent = tc2 + } + ) textFieldCursorAppendNewline :: Maybe TextFieldCursor -> TextFieldCursor textFieldCursorAppendNewline mtfc = let tfc = fromMaybe emptyTextFieldCursor mtfc - in tfc & - textFieldCursorNonEmptyCursorL %~ - (\lec@NonEmptyCursor {..} -> - let (tc1, tc2) = textCursorSplit nonEmptyCursorCurrent - in lec - { nonEmptyCursorCurrent = tc1 - , nonEmptyCursorNext = rebuildTextCursor tc2 : nonEmptyCursorNext - }) + in tfc + & textFieldCursorNonEmptyCursorL + %~ ( \lec@NonEmptyCursor {..} -> + let (tc1, tc2) = textCursorSplit nonEmptyCursorCurrent + in lec + { nonEmptyCursorCurrent = tc1, + nonEmptyCursorNext = rebuildTextCursor tc2 : nonEmptyCursorNext + } + ) textFieldCursorRemove :: TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) textFieldCursorRemove tfc = if nullTextFieldCursor tfc then Just Deleted - else focusPossibleDeleteOrUpdate - textFieldCursorNonEmptyCursorL - (\lec@NonEmptyCursor {..} -> - case textCursorRemove nonEmptyCursorCurrent of - Just (Updated ctc) -> Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc - _ -> - case nonEmptyCursorPrev of - [] -> Nothing - (pl:pls) -> - Just $ + else + focusPossibleDeleteOrUpdate + textFieldCursorNonEmptyCursorL + ( \lec@NonEmptyCursor {..} -> + case textCursorRemove nonEmptyCursorCurrent of + Just (Updated ctc) -> Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc + _ -> + case nonEmptyCursorPrev of + [] -> Nothing + (pl : pls) -> + Just $ Updated $ - lec - { nonEmptyCursorPrev = pls - , nonEmptyCursorCurrent = - textCursorCombine (unsafeMakeTextCursor pl) nonEmptyCursorCurrent - }) - tfc + lec + { nonEmptyCursorPrev = pls, + nonEmptyCursorCurrent = + textCursorCombine (unsafeMakeTextCursor pl) nonEmptyCursorCurrent + } + ) + tfc textFieldCursorDelete :: TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) textFieldCursorDelete tfc = if nullTextFieldCursor tfc then Just Deleted - else focusPossibleDeleteOrUpdate - textFieldCursorNonEmptyCursorL - (\lec@NonEmptyCursor {..} -> - case textCursorDelete nonEmptyCursorCurrent of - Just (Updated ctc) -> Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc - _ -> - case nonEmptyCursorNext of - [] -> Nothing - (pl:pls) -> - Just $ + else + focusPossibleDeleteOrUpdate + textFieldCursorNonEmptyCursorL + ( \lec@NonEmptyCursor {..} -> + case textCursorDelete nonEmptyCursorCurrent of + Just (Updated ctc) -> Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc + _ -> + case nonEmptyCursorNext of + [] -> Nothing + (pl : pls) -> + Just $ Updated $ - lec - { nonEmptyCursorCurrent = - textCursorCombine nonEmptyCursorCurrent (unsafeMakeTextCursor pl) - , nonEmptyCursorNext = pls - }) - tfc + lec + { nonEmptyCursorCurrent = + textCursorCombine nonEmptyCursorCurrent (unsafeMakeTextCursor pl), + nonEmptyCursorNext = pls + } + ) + tfc textFieldCursorSelectStartOfLine :: TextFieldCursor -> TextFieldCursor textFieldCursorSelectStartOfLine = textFieldCursorSelectedL %~ textCursorSelectStart diff --git a/src/Cursor/Tree.hs b/src/Cursor/Tree.hs --- a/src/Cursor/Tree.hs +++ b/src/Cursor/Tree.hs @@ -1,29 +1,40 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} module Cursor.Tree - ( TreeCursor(..) - , TreeAbove(..) + ( TreeCursor (..), + TreeAbove (..), + -- * Types - , module Cursor.Tree.Types + module Cursor.Tree.Types, + -- * Construction, destruction - , module Cursor.Tree.Base + module Cursor.Tree.Base, + -- * Drawing - , module Cursor.Tree.Draw + module Cursor.Tree.Draw, + -- * Collapsing - , module Cursor.Tree.Collapse + module Cursor.Tree.Collapse, + -- * Movements - , module Cursor.Tree.Movement + module Cursor.Tree.Movement, + -- * Insertions - , module Cursor.Tree.Insert + module Cursor.Tree.Insert, + -- * Deletions - , module Cursor.Tree.Delete + module Cursor.Tree.Delete, + -- * Swapping - , module Cursor.Tree.Swap + module Cursor.Tree.Swap, + -- * Promotions - , module Cursor.Tree.Promote + module Cursor.Tree.Promote, + -- * Demotions - , module Cursor.Tree.Demote - ) where + module Cursor.Tree.Demote, + ) +where import Cursor.Tree.Base import Cursor.Tree.Collapse diff --git a/src/Cursor/Tree/Base.hs b/src/Cursor/Tree/Base.hs --- a/src/Cursor/Tree/Base.hs +++ b/src/Cursor/Tree/Base.hs @@ -3,19 +3,20 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Tree.Base - ( singletonTreeCursor - , makeTreeCursor - , makeTreeCursorWithSelection - , rebuildTreeCursor - , mapTreeCursor - , currentTree - , makeTreeCursorWithAbove - , traverseTreeCursor - , foldTreeCursor - ) where + ( singletonTreeCursor, + makeTreeCursor, + makeNodeTreeCursor, + makeTreeCursorWithSelection, + rebuildTreeCursor, + mapTreeCursor, + currentTree, + makeTreeCursorWithAbove, + traverseTreeCursor, + foldTreeCursor, + ) +where import Control.Monad - import Cursor.Tree.Types singletonTreeCursor :: a -> TreeCursor a b @@ -24,25 +25,28 @@ makeTreeCursor :: (b -> a) -> CTree b -> TreeCursor a b makeTreeCursor g (CNode v fs) = TreeCursor {treeAbove = Nothing, treeCurrent = g v, treeBelow = fs} +makeNodeTreeCursor :: a -> CForest b -> TreeCursor a b +makeNodeTreeCursor v fs = TreeCursor {treeAbove = Nothing, treeCurrent = v, treeBelow = fs} + makeTreeCursorWithSelection :: - (a -> b) -> (b -> a) -> TreeCursorSelection -> CTree b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursorSelection -> CTree b -> Maybe (TreeCursor a b) makeTreeCursorWithSelection f g sel = walkDown sel . makeTreeCursor g where walkDown SelectNode tc = pure tc walkDown (SelectChild i s) TreeCursor {..} = (walkDown s =<<) $ - case splitAt i $ unpackCForest treeBelow of - (_, []) -> Nothing - (lefts, current:rights) -> - Just $ - makeTreeCursorWithAbove g current $ - Just $ - TreeAbove - { treeAboveLefts = reverse lefts - , treeAboveAbove = treeAbove - , treeAboveNode = f treeCurrent - , treeAboveRights = rights - } + case splitAt i $ unpackCForest treeBelow of + (_, []) -> Nothing + (lefts, current : rights) -> + Just $ + makeTreeCursorWithAbove g current $ + Just $ + TreeAbove + { treeAboveLefts = reverse lefts, + treeAboveAbove = treeAbove, + treeAboveNode = f treeCurrent, + treeAboveRights = rights + } rebuildTreeCursor :: (a -> b) -> TreeCursor a b -> CTree b rebuildTreeCursor f TreeCursor {..} = wrapAbove treeAbove $ CNode (f treeCurrent) treeBelow @@ -50,12 +54,17 @@ wrapAbove Nothing t = t wrapAbove (Just TreeAbove {..}) t = wrapAbove treeAboveAbove $ - CNode treeAboveNode $ openForest $ concat [reverse treeAboveLefts, [t], treeAboveRights] + CNode treeAboveNode $ + openForest $ + concat [reverse treeAboveLefts, [t], treeAboveRights] mapTreeCursor :: (a -> c) -> (b -> d) -> TreeCursor a b -> TreeCursor c d mapTreeCursor f g TreeCursor {..} = TreeCursor - {treeAbove = fmap g <$> treeAbove, treeCurrent = f treeCurrent, treeBelow = fmap g treeBelow} + { treeAbove = fmap g <$> treeAbove, + treeCurrent = f treeCurrent, + treeBelow = fmap g treeBelow + } currentTree :: (a -> b) -> TreeCursor a b -> CTree b currentTree f TreeCursor {..} = CNode (f treeCurrent) treeBelow @@ -65,11 +74,12 @@ TreeCursor {treeAbove = mta, treeCurrent = g a, treeBelow = forest} traverseTreeCursor :: - forall a b m c. Monad m - => ([CTree b] -> b -> [CTree b] -> c -> m c) - -> (a -> CForest b -> m c) - -> TreeCursor a b - -> m c + forall a b m c. + Monad m => + ([CTree b] -> b -> [CTree b] -> c -> m c) -> + (a -> CForest b -> m c) -> + TreeCursor a b -> + m c traverseTreeCursor wrapFunc currentFunc TreeCursor {..} = currentFunc treeCurrent treeBelow >>= wrapAbove treeAbove where @@ -81,11 +91,11 @@ wrapFunc (reverse treeAboveLefts) treeAboveNode treeAboveRights >=> wrapAbove treeAboveAbove foldTreeCursor :: - forall a b c. - ([CTree b] -> b -> [CTree b] -> c -> c) - -> (a -> CForest b -> c) - -> TreeCursor a b - -> c + forall a b c. + ([CTree b] -> b -> [CTree b] -> c -> c) -> + (a -> CForest b -> c) -> + TreeCursor a b -> + c foldTreeCursor wrapFunc currentFunc TreeCursor {..} = wrapAbove treeAbove $ currentFunc treeCurrent treeBelow where diff --git a/src/Cursor/Tree/Collapse.hs b/src/Cursor/Tree/Collapse.hs --- a/src/Cursor/Tree/Collapse.hs +++ b/src/Cursor/Tree/Collapse.hs @@ -1,14 +1,14 @@ module Cursor.Tree.Collapse - ( treeCursorOpenCurrentForest - , treeCursorCloseCurrentForest - , treeCursorToggleCurrentForest - , treeCursorOpenCurrentForestRecursively - , treeCursorToggleCurrentForestRecursively - ) where - -import qualified Data.List.NonEmpty as NE + ( treeCursorOpenCurrentForest, + treeCursorCloseCurrentForest, + treeCursorToggleCurrentForest, + treeCursorOpenCurrentForestRecursively, + treeCursorToggleCurrentForestRecursively, + ) +where import Cursor.Tree.Types +import qualified Data.List.NonEmpty as NE treeCursorOpenCurrentForest :: TreeCursor a b -> Maybe (TreeCursor a b) treeCursorOpenCurrentForest tc = diff --git a/src/Cursor/Tree/Delete.hs b/src/Cursor/Tree/Delete.hs --- a/src/Cursor/Tree/Delete.hs +++ b/src/Cursor/Tree/Delete.hs @@ -2,77 +2,76 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Tree.Delete - ( treeCursorDeleteSubTreeAndSelectPrevious - , treeCursorDeleteSubTreeAndSelectNext - , treeCursorDeleteSubTreeAndSelectAbove - , treeCursorRemoveSubTree - , treeCursorDeleteSubTree - , treeCursorDeleteElemAndSelectPrevious - , treeCursorDeleteElemAndSelectNext - , treeCursorDeleteElemAndSelectAbove - , treeCursorRemoveElem - , treeCursorDeleteElem - ) where - -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Tree + ( treeCursorDeleteSubTreeAndSelectPrevious, + treeCursorDeleteSubTreeAndSelectNext, + treeCursorDeleteSubTreeAndSelectAbove, + treeCursorRemoveSubTree, + treeCursorDeleteSubTree, + treeCursorDeleteElemAndSelectPrevious, + treeCursorDeleteElemAndSelectNext, + treeCursorDeleteElemAndSelectAbove, + treeCursorRemoveElem, + treeCursorDeleteElem, + ) +where import Control.Applicative - import Cursor.Tree.Base import Cursor.Tree.Types import Cursor.Types +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Tree treeCursorDeleteSubTreeAndSelectPrevious :: - (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) + (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) treeCursorDeleteSubTreeAndSelectPrevious g TreeCursor {..} = case treeAbove of Nothing -> Just Deleted Just ta -> case treeAboveLefts ta of [] -> Nothing - tree:xs -> Just . Updated . makeTreeCursorWithAbove g tree $ Just ta {treeAboveLefts = xs} + tree : xs -> Just . Updated . makeTreeCursorWithAbove g tree $ Just ta {treeAboveLefts = xs} treeCursorDeleteSubTreeAndSelectNext :: - (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) + (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) treeCursorDeleteSubTreeAndSelectNext g TreeCursor {..} = case treeAbove of Nothing -> Just Deleted Just ta -> case treeAboveRights ta of [] -> Nothing - tree:xs -> Just . Updated . makeTreeCursorWithAbove g tree $ Just ta {treeAboveRights = xs} + tree : xs -> Just . Updated . makeTreeCursorWithAbove g tree $ Just ta {treeAboveRights = xs} treeCursorDeleteSubTreeAndSelectAbove :: - (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorDeleteSubTreeAndSelectAbove g TreeCursor {..} = case treeAbove of Nothing -> Deleted Just TreeAbove {..} -> Updated $ - TreeCursor - { treeAbove = treeAboveAbove - , treeCurrent = g treeAboveNode - , treeBelow = openForest $ reverse treeAboveLefts ++ treeAboveRights - } + TreeCursor + { treeAbove = treeAboveAbove, + treeCurrent = g treeAboveNode, + treeBelow = openForest $ reverse treeAboveLefts ++ treeAboveRights + } treeCursorRemoveSubTree :: (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorRemoveSubTree g tc = joinDeletes (treeCursorDeleteSubTreeAndSelectPrevious g tc) - (treeCursorDeleteSubTreeAndSelectNext g tc) <|> - treeCursorDeleteSubTreeAndSelectAbove g tc + (treeCursorDeleteSubTreeAndSelectNext g tc) + <|> treeCursorDeleteSubTreeAndSelectAbove g tc treeCursorDeleteSubTree :: (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorDeleteSubTree g tc = joinDeletes (treeCursorDeleteSubTreeAndSelectNext g tc) - (treeCursorDeleteSubTreeAndSelectPrevious g tc) <|> - treeCursorDeleteSubTreeAndSelectAbove g tc + (treeCursorDeleteSubTreeAndSelectPrevious g tc) + <|> treeCursorDeleteSubTreeAndSelectAbove g tc treeCursorDeleteElemAndSelectPrevious :: - (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) + (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) treeCursorDeleteElemAndSelectPrevious g TreeCursor {..} = case treeAbove of Nothing -> @@ -82,14 +81,16 @@ Just ta -> case treeAboveLefts ta of [] -> Nothing - tree:xs -> + tree : xs -> Just . Updated . makeTreeCursorWithAbove g tree $ - Just - ta - {treeAboveLefts = xs, treeAboveRights = unpackCForest treeBelow ++ treeAboveRights ta} + Just + ta + { treeAboveLefts = xs, + treeAboveRights = unpackCForest treeBelow ++ treeAboveRights ta + } treeCursorDeleteElemAndSelectNext :: - (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) + (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) treeCursorDeleteElemAndSelectNext g TreeCursor {..} = case treeBelow of EmptyCForest -> @@ -98,7 +99,7 @@ Just ta -> case treeAboveRights ta of [] -> Nothing - tree:xs -> + tree : xs -> Just . Updated . makeTreeCursorWithAbove g tree $ Just ta {treeAboveRights = xs} ClosedForest ts -> case treeAbove of @@ -110,24 +111,24 @@ Just ta -> case treeAboveRights ta of [] -> Nothing - tree:xs -> + tree : xs -> Just . Updated . makeTreeCursorWithAbove g tree $ - Just - ta - { treeAboveLefts = map makeCTree (reverse $ NE.toList ts) ++ treeAboveLefts ta - , treeAboveRights = xs - } + Just + ta + { treeAboveLefts = map makeCTree (reverse $ NE.toList ts) ++ treeAboveLefts ta, + treeAboveRights = xs + } OpenForest (CNode e ts :| xs) -> let t = CNode e $ - case ts of - EmptyCForest -> openForest xs - OpenForest ts_ -> openForest $ NE.toList ts_ ++ xs - ClosedForest ts_ -> closedForest $ NE.toList ts_ ++ map rebuildCTree xs + case ts of + EmptyCForest -> openForest xs + OpenForest ts_ -> openForest $ NE.toList ts_ ++ xs + ClosedForest ts_ -> closedForest $ NE.toList ts_ ++ map rebuildCTree xs in Just . Updated $ makeTreeCursorWithAbove g t treeAbove treeCursorDeleteElemAndSelectAbove :: - (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) + (b -> a) -> TreeCursor a b -> Maybe (DeleteOrUpdate (TreeCursor a b)) treeCursorDeleteElemAndSelectAbove g TreeCursor {..} = case treeAbove of Nothing -> @@ -136,13 +137,13 @@ _ -> Nothing Just TreeAbove {..} -> Just $ - Updated $ - TreeCursor - { treeAbove = treeAboveAbove - , treeCurrent = g treeAboveNode - , treeBelow = - openForest $ reverse treeAboveLefts ++ unpackCForest treeBelow ++ treeAboveRights - } + Updated $ + TreeCursor + { treeAbove = treeAboveAbove, + treeCurrent = g treeAboveNode, + treeBelow = + openForest $ reverse treeAboveLefts ++ unpackCForest treeBelow ++ treeAboveRights + } treeCursorRemoveElem :: (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorRemoveElem g tc = diff --git a/src/Cursor/Tree/Demote.hs b/src/Cursor/Tree/Demote.hs --- a/src/Cursor/Tree/Demote.hs +++ b/src/Cursor/Tree/Demote.hs @@ -1,23 +1,21 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Demote - ( treeCursorDemoteElem - , treeCursorDemoteSubTree - , DemoteResult(..) - , treeCursorDemoteElemUnder - , treeCursorDemoteSubTreeUnder - ) where - -import GHC.Generics (Generic) - -import Data.Validity + ( treeCursorDemoteElem, + treeCursorDemoteSubTree, + DemoteResult (..), + treeCursorDemoteElemUnder, + treeCursorDemoteSubTreeUnder, + ) +where import Control.DeepSeq - import Cursor.Tree.Base import Cursor.Tree.Types +import Data.Validity +import GHC.Generics (Generic) -- | Demotes the current node to the level of its children. -- @@ -47,16 +45,16 @@ Just ta -> case treeAboveLefts ta of [] -> NoSiblingsToDemoteUnder - (CNode t ls:ts) -> + (CNode t ls : ts) -> Demoted $ - makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $ - Just - TreeAbove - { treeAboveLefts = reverse $ unpackCForest ls - , treeAboveAbove = Just ta {treeAboveLefts = ts} - , treeAboveNode = t - , treeAboveRights = unpackCForest $ treeBelow tc - } + makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $ + Just + TreeAbove + { treeAboveLefts = reverse $ unpackCForest ls, + treeAboveAbove = Just ta {treeAboveLefts = ts}, + treeAboveNode = t, + treeAboveRights = unpackCForest $ treeBelow tc + } -- | Demotes the current subtree to the level of its children. -- @@ -86,16 +84,16 @@ Just ta -> case treeAboveLefts ta of [] -> NoSiblingsToDemoteUnder - (CNode t ls:ts) -> + (CNode t ls : ts) -> Demoted $ - makeTreeCursorWithAbove g (currentTree f tc) $ - Just - TreeAbove - { treeAboveLefts = reverse $ unpackCForest ls - , treeAboveAbove = Just ta {treeAboveLefts = ts} - , treeAboveNode = t - , treeAboveRights = [] - } + makeTreeCursorWithAbove g (currentTree f tc) $ + Just + TreeAbove + { treeAboveLefts = reverse $ unpackCForest ls, + treeAboveAbove = Just ta {treeAboveLefts = ts}, + treeAboveNode = t, + treeAboveRights = [] + } data DemoteResult a = CannotDemoteTopNode @@ -134,12 +132,12 @@ { treeAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Just ta' - , treeAboveNode = b1 - , treeAboveRights = [] - } - , treeBelow = emptyCForest + { treeAboveLefts = [], + treeAboveAbove = Just ta', + treeAboveNode = b1, + treeAboveRights = [] + }, + treeBelow = emptyCForest } -- | Demotes the current subtree to the level of its children, by adding a root. @@ -162,9 +160,9 @@ { treeAbove = Just TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = treeAbove tc - , treeAboveNode = b - , treeAboveRights = [] + { treeAboveLefts = [], + treeAboveAbove = treeAbove tc, + treeAboveNode = b, + treeAboveRights = [] } } diff --git a/src/Cursor/Tree/Draw.hs b/src/Cursor/Tree/Draw.hs --- a/src/Cursor/Tree/Draw.hs +++ b/src/Cursor/Tree/Draw.hs @@ -2,19 +2,19 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Tree.Draw - ( drawTreeCursor - , treeCursorWithPointer - , showCForest - , showCTree - , showForest - , showTree - ) where + ( drawTreeCursor, + treeCursorWithPointer, + showCForest, + showCTree, + showForest, + showTree, + ) +where +import Cursor.Tree.Types import qualified Data.List.NonEmpty as NE import Data.Tree -import Cursor.Tree.Types - drawTreeCursor :: (Show a, Show b) => TreeCursor a b -> String drawTreeCursor = drawTree . treeCursorWithPointer @@ -26,8 +26,8 @@ wrapAbove Nothing t = t wrapAbove (Just TreeAbove {..}) t = wrapAbove treeAboveAbove $ - Node (show treeAboveNode) $ - concat [map showCTree $ reverse treeAboveLefts, [t], map showCTree treeAboveRights] + Node (show treeAboveNode) $ + concat [map showCTree $ reverse treeAboveLefts, [t], map showCTree treeAboveRights] showCForest :: Show a => CForest a -> Forest String showCForest EmptyCForest = [] diff --git a/src/Cursor/Tree/Insert.hs b/src/Cursor/Tree/Insert.hs --- a/src/Cursor/Tree/Insert.hs +++ b/src/Cursor/Tree/Insert.hs @@ -2,22 +2,34 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Tree.Insert - ( treeCursorInsert - , treeCursorInsertAndSelect - , treeCursorAppend - , treeCursorAppendAndSelect - , treeCursorAddChildAtPos - , treeCursorAddChildAtStart - , treeCursorAddChildAtEnd - ) where + ( treeCursorInsert, + treeCursorInsertAndSelect, + treeCursorInsertNodeSingleAndSelect, + treeCursorInsertNodeAndSelect, + treeCursorAppend, + treeCursorAppendAndSelect, + treeCursorAppendNodeSingleAndSelect, + treeCursorAppendNodeAndSelect, + treeCursorAddChildAtPos, + treeCursorAddChildAtStart, + treeCursorAddChildAtEnd, + treeCursorAddChildAtPosAndSelect, + treeCursorAddChildAtStartAndSelect, + treeCursorAddChildAtEndAndSelect, + treeCursorAddChildNodeSingleAtPosAndSelect, + treeCursorAddChildNodeSingleAtStartAndSelect, + treeCursorAddChildNodeSingleAtEndAndSelect, + treeCursorAddChildNodeAtPosAndSelect, + treeCursorAddChildNodeAtStartAndSelect, + treeCursorAddChildNodeAtEndAndSelect, + ) +where -import qualified Data.List.NonEmpty as NE +import Cursor.Tree.Types import Data.List.NonEmpty ((<|)) +import qualified Data.List.NonEmpty as NE import Data.Tree -import Cursor.Tree.Base -import Cursor.Tree.Types - treeCursorInsert :: Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorInsert tree tc@TreeCursor {..} = do ta <- treeAbove @@ -25,12 +37,21 @@ pure tc {treeAbove = Just newTreeAbove} treeCursorInsertAndSelect :: - (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) -treeCursorInsertAndSelect f g tree tc@TreeCursor {..} = do - ta <- treeAbove - let newTreeAbove = ta {treeAboveRights = currentTree f tc : treeAboveRights ta} - pure $ makeTreeCursorWithAbove g (makeCTree tree) $ Just newTreeAbove + (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorInsertAndSelect f g (Node value forest) = treeCursorInsertNodeAndSelect f (g value) (makeCForest forest) +treeCursorInsertNodeSingleAndSelect :: + (a -> b) -> a -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorInsertNodeSingleAndSelect f a = treeCursorInsertNodeAndSelect f a EmptyCForest + +treeCursorInsertNodeAndSelect :: + (a -> b) -> a -> CForest b -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorInsertNodeAndSelect f value forest tc = do + ta <- treeAbove tc + let ta' = ta {treeAboveRights = CNode (f (treeCurrent tc)) (treeBelow tc) : treeAboveRights ta} + tc' = tc {treeAbove = Just ta', treeCurrent = value, treeBelow = forest} + pure tc' + treeCursorAppend :: Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorAppend tree tc@TreeCursor {..} = do ta <- treeAbove @@ -38,12 +59,21 @@ pure tc {treeAbove = Just newTreeAbove} treeCursorAppendAndSelect :: - (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) -treeCursorAppendAndSelect f g tree tc@TreeCursor {..} = do - ta <- treeAbove - let newTreeAbove = ta {treeAboveLefts = currentTree f tc : treeAboveLefts ta} - pure $ makeTreeCursorWithAbove g (makeCTree tree) $ Just newTreeAbove + (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorAppendAndSelect f g (Node value forest) = treeCursorAppendNodeAndSelect f (g value) (makeCForest forest) +treeCursorAppendNodeSingleAndSelect :: + (a -> b) -> a -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorAppendNodeSingleAndSelect f a = treeCursorAppendNodeAndSelect f a EmptyCForest + +treeCursorAppendNodeAndSelect :: + (a -> b) -> a -> CForest b -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorAppendNodeAndSelect f value forest tc = do + ta <- treeAbove tc + let ta' = ta {treeAboveLefts = CNode (f (treeCurrent tc)) (treeBelow tc) : treeAboveLefts ta} + tc' = tc {treeAbove = Just ta', treeCurrent = value, treeBelow = forest} + pure tc' + -- TODO make this fail if the position doesn't make sense treeCursorAddChildAtPos :: Int -> Tree b -> TreeCursor a b -> TreeCursor a b treeCursorAddChildAtPos i t tc = @@ -69,3 +99,76 @@ EmptyCForest -> tc {treeBelow = openForest [makeCTree t]} ClosedForest ts -> tc {treeBelow = openForest $ map makeCTree $ NE.toList ts ++ [t]} OpenForest ts -> tc {treeBelow = openForest $ NE.toList ts ++ [makeCTree t]} + +treeCursorAddChildAtPosAndSelect :: + (a -> b) -> (b -> a) -> Int -> Tree b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildAtPosAndSelect f g i (Node t ts) = treeCursorAddChildNodeAtPosAndSelect f i (g t) ts + +treeCursorAddChildAtStartAndSelect :: + (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildAtStartAndSelect f g (Node t ts) = treeCursorAddChildNodeAtStartAndSelect f (g t) ts + +treeCursorAddChildAtEndAndSelect :: + (a -> b) -> (b -> a) -> Tree b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildAtEndAndSelect f g (Node t ts) = treeCursorAddChildNodeAtEndAndSelect f (g t) ts + +treeCursorAddChildNodeSingleAtPosAndSelect :: + (a -> b) -> Int -> a -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeSingleAtPosAndSelect f i a = treeCursorAddChildNodeAtPosAndSelect f i a [] + +treeCursorAddChildNodeSingleAtStartAndSelect :: + (a -> b) -> a -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeSingleAtStartAndSelect f a = treeCursorAddChildNodeAtStartAndSelect f a [] + +treeCursorAddChildNodeSingleAtEndAndSelect :: + (a -> b) -> a -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeSingleAtEndAndSelect f a = treeCursorAddChildNodeAtEndAndSelect f a [] + +treeCursorAddChildNodeAtPosAndSelect :: + (a -> b) -> Int -> a -> Forest b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeAtPosAndSelect f i t ts tc = + let (before, after) = splitAt i $ unpackCForest $ treeBelow tc + in TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = reverse before, + treeAboveAbove = treeAbove tc, + treeAboveNode = f (treeCurrent tc), + treeAboveRights = after + }, + treeCurrent = t, + treeBelow = makeCForest ts + } + +treeCursorAddChildNodeAtStartAndSelect :: + (a -> b) -> a -> Forest b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeAtStartAndSelect f t ts tc = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [], + treeAboveAbove = treeAbove tc, + treeAboveNode = f (treeCurrent tc), + treeAboveRights = unpackCForest $ treeBelow tc + }, + treeCurrent = t, + treeBelow = makeCForest ts + } + +treeCursorAddChildNodeAtEndAndSelect :: + (a -> b) -> a -> Forest b -> TreeCursor a b -> TreeCursor a b +treeCursorAddChildNodeAtEndAndSelect f t ts tc = + TreeCursor + { treeAbove = + Just + TreeAbove + { treeAboveLefts = reverse $ unpackCForest $ treeBelow tc, + treeAboveAbove = treeAbove tc, + treeAboveNode = f (treeCurrent tc), + treeAboveRights = [] + }, + treeCurrent = t, + treeBelow = makeCForest ts + } diff --git a/src/Cursor/Tree/Movement.hs b/src/Cursor/Tree/Movement.hs --- a/src/Cursor/Tree/Movement.hs +++ b/src/Cursor/Tree/Movement.hs @@ -2,33 +2,34 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Tree.Movement - ( treeCursorSelection - , TreeCursorSelection(..) - , treeCursorSelect - , treeCursorSelectPrev - , treeCursorSelectNext - , treeCursorSelectFirst - , treeCursorSelectLast - , treeCursorSelectAbove - , treeCursorSelectBelowAtPos - , treeCursorSelectBelowAtStart - , treeCursorSelectBelowAtEnd - , treeCursorSelectBelowAtStartRecursively - , treeCursorSelectBelowAtEndRecursively - , treeCursorSelectPrevOnSameLevel - , treeCursorSelectNextOnSameLevel - , treeCursorSelectAbovePrev - , treeCursorSelectAboveNext - ) where - -import qualified Data.List.NonEmpty as NE -import Data.Validity.Tree () + ( treeCursorSelection, + TreeCursorSelection (..), + treeCursorSelect, + treeCursorSelectPrev, + treeCursorSelectNext, + treeCursorSelectFirst, + treeCursorSelectLast, + treeCursorSelectAbove, + treeCursorSelectBelowAtPos, + treeCursorSelectBelowAtStart, + treeCursorSelectBelowAtEnd, + treeCursorSelectBelowAtStartRecursively, + treeCursorSelectBelowAtEndRecursively, + treeCursorSelectPrevOnSameLevel, + treeCursorSelectNextOnSameLevel, + treeCursorSelectFirstOnSameLevel, + treeCursorSelectLastOnSameLevel, + treeCursorSelectAbovePrev, + treeCursorSelectAboveNext, + ) +where import Control.Applicative import Control.Monad - import Cursor.Tree.Base import Cursor.Tree.Types +import qualified Data.List.NonEmpty as NE +import Data.Validity.Tree () treeCursorSelection :: TreeCursor a b -> TreeCursorSelection treeCursorSelection TreeCursor {..} = wrap treeAbove SelectNode @@ -38,18 +39,18 @@ wrap (Just ta) ts = wrap (treeAboveAbove ta) $ SelectChild (length $ treeAboveLefts ta) ts treeCursorSelect :: - (a -> b) -> (b -> a) -> TreeCursorSelection -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursorSelection -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelect f g sel = makeTreeCursorWithSelection f g sel . rebuildTreeCursor f treeCursorSelectPrev :: (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectPrev f g tc = - treeCursorSelectAbovePrev f g tc <|> treeCursorSelectPrevOnSameLevel f g tc <|> - treeCursorSelectAbove f g tc + treeCursorSelectAbovePrev f g tc <|> treeCursorSelectPrevOnSameLevel f g tc + <|> treeCursorSelectAbove f g tc treeCursorSelectNext :: (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectNext f g tc = - treeCursorSelectBelowAtStart f g tc <|> treeCursorSelectNextOnSameLevel f g tc <|> - treeCursorSelectAboveNext f g tc + treeCursorSelectBelowAtStart f g tc <|> treeCursorSelectNextOnSameLevel f g tc + <|> treeCursorSelectAboveNext f g tc treeCursorSelectFirst :: (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b treeCursorSelectFirst f g tc = maybe tc (treeCursorSelectFirst f g) $ treeCursorSelectPrev f g tc @@ -67,7 +68,7 @@ in Just $ makeTreeCursorWithAbove g newTree treeAboveAbove treeCursorSelectBelowAtPos :: - (a -> b) -> (b -> a) -> Int -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> Int -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtPos f g pos TreeCursor {..} = case treeBelow of EmptyCForest -> Nothing @@ -75,16 +76,16 @@ OpenForest ts -> case splitAt pos $ NE.toList ts of (_, []) -> Nothing - (lefts, current:rights) -> - Just $ - makeTreeCursorWithAbove g current $ + (lefts, current : rights) -> Just $ - TreeAbove - { treeAboveLefts = reverse lefts - , treeAboveAbove = treeAbove - , treeAboveNode = f treeCurrent - , treeAboveRights = rights - } + makeTreeCursorWithAbove g current $ + Just $ + TreeAbove + { treeAboveLefts = reverse lefts, + treeAboveAbove = treeAbove, + treeAboveNode = f treeCurrent, + treeAboveRights = rights + } treeCursorSelectBelowAtStart :: (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtStart f g = treeCursorSelectBelowAtPos f g 0 @@ -97,13 +98,13 @@ OpenForest ts -> treeCursorSelectBelowAtPos f g (length ts - 1) tc treeCursorSelectBelowAtStartRecursively :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtStartRecursively f g tc = go <$> treeCursorSelectBelowAtStart f g tc where go c = maybe c go $ treeCursorSelectBelowAtStart f g c treeCursorSelectBelowAtEndRecursively :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtEndRecursively f g tc = go <$> treeCursorSelectBelowAtEnd f g tc where go c = maybe c go $ treeCursorSelectBelowAtEnd f g c @@ -113,19 +114,31 @@ ta <- treeAbove case treeAboveLefts ta of [] -> Nothing - tree:xs -> + tree : xs -> Just . makeTreeCursorWithAbove g tree $ - Just ta {treeAboveLefts = xs, treeAboveRights = currentTree f tc : treeAboveRights ta} + Just ta {treeAboveLefts = xs, treeAboveRights = currentTree f tc : treeAboveRights ta} treeCursorSelectNextOnSameLevel :: (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectNextOnSameLevel f g tc@TreeCursor {..} = do ta <- treeAbove case treeAboveRights ta of [] -> Nothing - tree:xs -> + tree : xs -> Just . makeTreeCursorWithAbove g tree . Just $ - ta {treeAboveLefts = currentTree f tc : treeAboveLefts ta, treeAboveRights = xs} + ta {treeAboveLefts = currentTree f tc : treeAboveLefts ta, treeAboveRights = xs} +treeCursorSelectFirstOnSameLevel :: (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b +treeCursorSelectFirstOnSameLevel f g tc = + case treeCursorSelectPrevOnSameLevel f g tc of + Nothing -> tc + Just tc' -> treeCursorSelectFirstOnSameLevel f g tc' + +treeCursorSelectLastOnSameLevel :: (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b +treeCursorSelectLastOnSameLevel f g tc = + case treeCursorSelectNextOnSameLevel f g tc of + Nothing -> tc + Just tc' -> treeCursorSelectLastOnSameLevel f g tc' + -- | Go back and down as far as necessary to find a previous element on a level below treeCursorSelectAbovePrev :: (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectAbovePrev f g = @@ -142,10 +155,7 @@ case treeBelow tc of EmptyCForest -> go tc ClosedForest _ -> go tc - OpenForest ts -> - if null ts - then go tc - else Nothing + OpenForest _ -> Nothing where go tc_ = do tc' <- treeCursorSelectAbove f g tc_ diff --git a/src/Cursor/Tree/Promote.hs b/src/Cursor/Tree/Promote.hs --- a/src/Cursor/Tree/Promote.hs +++ b/src/Cursor/Tree/Promote.hs @@ -1,22 +1,20 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Promote - ( treeCursorPromoteElem - , PromoteElemResult(..) - , treeCursorPromoteSubTree - , PromoteResult(..) - ) where - -import GHC.Generics (Generic) - -import Data.Validity + ( treeCursorPromoteElem, + PromoteElemResult (..), + treeCursorPromoteSubTree, + PromoteResult (..), + ) +where import Control.DeepSeq - import Cursor.Tree.Base import Cursor.Tree.Types +import Data.Validity +import GHC.Generics (Generic) -- | Promotes the current node to the level of its parent. -- @@ -46,27 +44,27 @@ -- > |- d <-- -- > |- h treeCursorPromoteElem :: - (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteElemResult (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteElemResult (TreeCursor a b) treeCursorPromoteElem f g tc = do ta <- maybe CannotPromoteTopElem pure $ treeAbove tc - -- We need to put the below under the above lefts at the end + -- We need to put the below under the above lefts at the end lefts <- case treeBelow tc of EmptyCForest -> pure $ treeAboveLefts ta _ -> case treeAboveLefts ta of [] -> NoSiblingsToAdoptChildren - (CNode t ls:ts) -> + (CNode t ls : ts) -> pure $ CNode t (openForest $ unpackCForest ls ++ unpackCForest (treeBelow tc)) : ts taa <- maybe NoGrandparentToPromoteElemUnder pure $ treeAboveAbove ta pure $ makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $ - Just $ - taa - { treeAboveLefts = - CNode (treeAboveNode ta) (openForest $ reverse lefts ++ treeAboveRights ta) : - treeAboveLefts taa - } + Just $ + taa + { treeAboveLefts = + CNode (treeAboveNode ta) (openForest $ reverse lefts ++ treeAboveRights ta) : + treeAboveLefts taa + } data PromoteElemResult a = CannotPromoteTopElem @@ -128,12 +126,12 @@ taa <- maybe NoGrandparentToPromoteUnder pure $ treeAboveAbove ta pure $ makeTreeCursorWithAbove g (currentTree f tc) $ - Just $ - taa - { treeAboveLefts = - CNode (treeAboveNode ta) (openForest $ reverse (treeAboveLefts ta) ++ treeAboveRights ta) : - treeAboveLefts taa - } + Just $ + taa + { treeAboveLefts = + CNode (treeAboveNode ta) (openForest $ reverse (treeAboveLefts ta) ++ treeAboveRights ta) : + treeAboveLefts taa + } data PromoteResult a = CannotPromoteTopNode diff --git a/src/Cursor/Tree/Swap.hs b/src/Cursor/Tree/Swap.hs --- a/src/Cursor/Tree/Swap.hs +++ b/src/Cursor/Tree/Swap.hs @@ -1,20 +1,18 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Swap - ( treeCursorSwapPrev - , treeCursorSwapNext - , SwapResult(..) - ) where - -import Data.Validity - -import GHC.Generics (Generic) + ( treeCursorSwapPrev, + treeCursorSwapNext, + SwapResult (..), + ) +where import Control.DeepSeq - import Cursor.Tree.Types +import Data.Validity +import GHC.Generics (Generic) -- | Swaps the current node with the previous node on the same level -- @@ -38,9 +36,9 @@ Just ta -> case treeAboveLefts ta of [] -> NoSiblingsToSwapWith - (t:ts) -> + (t : ts) -> Swapped $ - tc {treeAbove = Just ta {treeAboveLefts = ts, treeAboveRights = t : treeAboveRights ta}} + tc {treeAbove = Just ta {treeAboveLefts = ts, treeAboveRights = t : treeAboveRights ta}} -- | Swaps the current node with the next node on the same level -- @@ -64,9 +62,9 @@ Just ta -> case treeAboveRights ta of [] -> NoSiblingsToSwapWith - (t:ts) -> + (t : ts) -> Swapped $ - tc {treeAbove = Just ta {treeAboveLefts = t : treeAboveLefts ta, treeAboveRights = ts}} + tc {treeAbove = Just ta {treeAboveLefts = t : treeAboveLefts ta, treeAboveRights = ts}} data SwapResult a = SwapperIsTopNode diff --git a/src/Cursor/Tree/Types.hs b/src/Cursor/Tree/Types.hs --- a/src/Cursor/Tree/Types.hs +++ b/src/Cursor/Tree/Types.hs @@ -1,53 +1,51 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Types - ( TreeCursor(..) - , treeCursorAboveL - , treeCursorCurrentL - , treeCursorBelowL - , treeCursorCurrentSubTreeL - , TreeAbove(..) - , treeAboveLeftsL - , treeAboveAboveL - , treeAboveNodeL - , treeAboveRightsL - , TreeCursorSelection(..) - -- * CTree - , CTree(..) - , makeCTree - , cTree - , rebuildCTree - , CForest(..) - , makeCForest - , cForest - , rebuildCForest - , emptyCForest - , openForest - , closedForest - , lengthCForest - , unpackCForest - ) where + ( TreeCursor (..), + treeCursorAboveL, + treeCursorCurrentL, + treeCursorBelowL, + treeCursorCurrentSubTreeL, + TreeAbove (..), + treeAboveLeftsL, + treeAboveAboveL, + treeAboveNodeL, + treeAboveRightsL, + TreeCursorSelection (..), -import GHC.Generics (Generic) + -- * CTree + CTree (..), + makeCTree, + cTree, + rebuildCTree, + CForest (..), + makeCForest, + cForest, + rebuildCForest, + emptyCForest, + openForest, + closedForest, + lengthCForest, + unpackCForest, + ) +where -import Data.List.NonEmpty (NonEmpty(..)) +import Control.DeepSeq +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Tree import Data.Validity import Data.Validity.Tree () - -import Control.DeepSeq - +import GHC.Generics (Generic) import Lens.Micro -data TreeCursor a b = - TreeCursor - { treeAbove :: !(Maybe (TreeAbove b)) - , treeCurrent :: !a - , treeBelow :: !(CForest b) - } +data TreeCursor a b = TreeCursor + { treeAbove :: !(Maybe (TreeAbove b)), + treeCurrent :: !a, + treeBelow :: !(CForest b) + } deriving (Show, Eq, Generic) instance (Validity a, Validity b) => Validity (TreeCursor a b) @@ -67,13 +65,12 @@ treeCursorCurrentSubTreeL = lens (\tc -> (treeCurrent tc, treeBelow tc)) (\tc (a, cf) -> tc {treeCurrent = a, treeBelow = cf}) -data TreeAbove b = - TreeAbove - { treeAboveLefts :: ![CTree b] -- In reverse order - , treeAboveAbove :: !(Maybe (TreeAbove b)) - , treeAboveNode :: !b - , treeAboveRights :: ![CTree b] - } +data TreeAbove b = TreeAbove + { treeAboveLefts :: ![CTree b], -- In reverse order + treeAboveAbove :: !(Maybe (TreeAbove b)), + treeAboveNode :: !b, + treeAboveRights :: ![CTree b] + } deriving (Show, Eq, Generic, Functor) instance Validity b => Validity (TreeAbove b) @@ -101,8 +98,8 @@ instance NFData TreeCursorSelection -data CTree a = - CNode !a (CForest a) +data CTree a + = CNode !a (CForest a) deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (CTree a) diff --git a/src/Cursor/Types.hs b/src/Cursor/Types.hs --- a/src/Cursor/Types.hs +++ b/src/Cursor/Types.hs @@ -3,15 +3,11 @@ module Cursor.Types where -import GHC.Generics (Generic) - +import Control.Applicative +import Data.Functor.Compose import qualified Data.Text.Internal as T import Data.Validity - -import Data.Functor.Compose - -import Control.Applicative - +import GHC.Generics (Generic) import Lens.Micro isSafeChar :: Char -> Bool @@ -39,6 +35,11 @@ Updated a <|> _ = Updated a Deleted <|> doua = doua +instance Monad DeleteOrUpdate where + dou >>= f = case dou of + Updated a -> f a + Deleted -> Deleted + joinDeletes :: Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> DeleteOrUpdate a joinDeletes m1 m2 = case (m1, m2) of @@ -47,10 +48,10 @@ (Just a, _) -> a joinDeletes3 :: - Maybe (DeleteOrUpdate a) - -> Maybe (DeleteOrUpdate a) - -> Maybe (DeleteOrUpdate a) - -> DeleteOrUpdate a + Maybe (DeleteOrUpdate a) -> + Maybe (DeleteOrUpdate a) -> + Maybe (DeleteOrUpdate a) -> + DeleteOrUpdate a joinDeletes3 m1 m2 m3 = case (m1, m2, m3) of (Nothing, Nothing, Nothing) -> Deleted @@ -59,11 +60,11 @@ (Just a, _, _) -> a joinPossibleDeletes :: - Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) + Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) joinPossibleDeletes d1 d2 = getCompose $ Compose d1 <|> Compose d2 focusPossibleDeleteOrUpdate :: - Lens' b a -> (a -> Maybe (DeleteOrUpdate a)) -> b -> Maybe (DeleteOrUpdate b) + Lens' b a -> (a -> Maybe (DeleteOrUpdate a)) -> b -> Maybe (DeleteOrUpdate b) focusPossibleDeleteOrUpdate l func = getCompose . l (Compose . func) dullMDelete :: Maybe (DeleteOrUpdate a) -> Maybe a