diff --git a/cursor.cabal b/cursor.cabal --- a/cursor.cabal +++ b/cursor.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: d3e45c022c743b9993002cab8f947d4f602837160cff153a1836da5acbfa3cd1 +-- hash: 0e420392500f690eef48970779eb994bc7dd29904db2097a73381264887accfb name: cursor -version: 0.0.0.1 +version: 0.1.0.0 synopsis: Purely Functional Cursors description: Purely Functional Cursors for common data structures category: Editor @@ -16,7 +18,6 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 library exposed-modules: diff --git a/src/Cursor/Forest.hs b/src/Cursor/Forest.hs --- a/src/Cursor/Forest.hs +++ b/src/Cursor/Forest.hs @@ -4,75 +4,80 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Forest - ( ForestCursor(..) - , makeForestCursor - , rebuildForestCursor - , drawForestCursor - , mapForestCursor - , forestCursorListCursorL - , forestCursorSelectedTreeL - , forestCursorSelectPrevTreeCursor - , forestCursorSelectNextTreeCursor - , forestCursorSelectFirstTreeCursor - , forestCursorSelectLastTreeCursor - , forestCursorSelectPrev - , forestCursorSelectNext - , forestCursorSelectPrevOnSameLevel - , forestCursorSelectNextOnSameLevel - , forestCursorSelectFirst - , forestCursorSelectLast - , forestCursorSelectBelowAtPos - , forestCursorSelectBelowAtStart - , forestCursorSelectBelowAtEnd - , forestCursorSelection - , forestCursorSelectIndex - , forestCursorCloseCurrentForest - , forestCursorOpenCurrentForest - , forestCursorToggleCurrentForest - , 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 - ) where + ( 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) @@ -91,9 +96,11 @@ import Cursor.Tree import Cursor.Types -newtype ForestCursor a b = ForestCursor +newtype ForestCursor a b = + ForestCursor { forestCursorListCursor :: NonEmptyCursor (TreeCursor a b) (CTree b) - } deriving (Show, Eq, Generic) + } + deriving (Show, Eq, Generic) instance (Validity a, Validity b) => Validity (ForestCursor a b) @@ -102,318 +109,319 @@ rebuildForestCursor :: (a -> b) -> ForestCursor a b -> NonEmpty (CTree b) rebuildForestCursor f = - rebuildNonEmptyCursor (rebuildTreeCursor f) . forestCursorListCursor + rebuildNonEmptyCursor (rebuildTreeCursor f) . forestCursorListCursor drawForestCursor :: (Show a, Show b) => ForestCursor a b -> String drawForestCursor ForestCursor {..} = - drawForest $ - (map showCTree $ reverse $ nonEmptyCursorPrev forestCursorListCursor) ++ - [treeCursorWithPointer $ nonEmptyCursorCurrent forestCursorListCursor] ++ - (map showCTree $ nonEmptyCursorNext forestCursorListCursor) + drawForest $ + (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 %~ 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} + 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) + 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) + forestCursorListCursorL $ + nonEmptyCursorSelectNext (rebuildTreeCursor f) (makeTreeCursor g) forestCursorSelectFirstTreeCursor :: - (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b forestCursorSelectFirstTreeCursor f g = - forestCursorListCursorL %~ - (nonEmptyCursorSelectFirst (rebuildTreeCursor f) (makeTreeCursor g)) + forestCursorListCursorL %~ + (nonEmptyCursorSelectFirst (rebuildTreeCursor f) (makeTreeCursor g)) forestCursorSelectLastTreeCursor :: - (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b forestCursorSelectLastTreeCursor f g = - forestCursorListCursorL %~ - (nonEmptyCursorSelectLast (rebuildTreeCursor f) (makeTreeCursor g)) + forestCursorListCursorL %~ + (nonEmptyCursorSelectLast (rebuildTreeCursor f) (makeTreeCursor g)) forestCursorSelectNext :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (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) + (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 forestCursorSelectFirst :: - (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b forestCursorSelectFirst f g fc = - case forestCursorSelectPrevTreeCursor f g fc of + case forestCursorSelectPrevTreeCursor f g fc of + Just fc' -> forestCursorSelectFirst f g fc' + Nothing -> + case forestCursorSelectPrev f g fc of Just fc' -> forestCursorSelectFirst f g fc' - Nothing -> - case forestCursorSelectPrev f g fc of - Just fc' -> forestCursorSelectFirst f g fc' - Nothing -> fc + Nothing -> fc forestCursorSelectLast :: - (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b forestCursorSelectLast f g fc = - case forestCursorSelectNextTreeCursor f g fc of + case forestCursorSelectNextTreeCursor f g fc of + Just fc' -> forestCursorSelectLast f g fc' + Nothing -> + case forestCursorSelectNext f g fc of Just fc' -> forestCursorSelectLast f g fc' - Nothing -> - case forestCursorSelectNext f g fc of - Just fc' -> forestCursorSelectLast f g fc' - Nothing -> fc + Nothing -> fc +forestCursorSelectAbove :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +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 + 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 + forestCursorSelectedTreeL $ treeCursorSelectBelowAtStart f g forestCursorSelectBelowAtEnd :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSelectBelowAtEnd f g = - forestCursorSelectedTreeL $ treeCursorSelectBelowAtEnd f g + forestCursorSelectedTreeL $ treeCursorSelectBelowAtEnd f g forestCursorSelection :: ForestCursor a b -> Int forestCursorSelection fc = - nonEmptyCursorSelection $ fc ^. forestCursorListCursorL + 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) + forestCursorListCursorL + (nonEmptyCursorSelectIndex (rebuildTreeCursor f) (makeTreeCursor g) i) forestCursorOpenCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) forestCursorOpenCurrentForest = - forestCursorSelectedTreeL treeCursorOpenCurrentForest + forestCursorSelectedTreeL treeCursorOpenCurrentForest forestCursorCloseCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) forestCursorCloseCurrentForest = - forestCursorSelectedTreeL treeCursorCloseCurrentForest + forestCursorSelectedTreeL treeCursorCloseCurrentForest forestCursorToggleCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) forestCursorToggleCurrentForest = - forestCursorSelectedTreeL treeCursorToggleCurrentForest + forestCursorSelectedTreeL treeCursorToggleCurrentForest +forestCursorOpenCurrentForestRecursively :: + ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorOpenCurrentForestRecursively = + forestCursorSelectedTreeL treeCursorOpenCurrentForestRecursively + +forestCursorToggleCurrentForestRecursively :: + ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorToggleCurrentForestRecursively = + forestCursorSelectedTreeL treeCursorToggleCurrentForestRecursively + forestCursorInsertEntireTree :: Tree b -> ForestCursor a b -> ForestCursor a b forestCursorInsertEntireTree t = - forestCursorListCursorL %~ nonEmptyCursorInsert (makeCTree 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 + forestCursorListCursorL %~ + nonEmptyCursorInsertAndSelect (rebuildTreeCursor f) tc forestCursorAppendEntireTree :: Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAppendEntireTree t = - forestCursorListCursorL %~ nonEmptyCursorAppend (makeCTree 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 + 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) + fromMaybe (forestCursorInsertEntireTree t fc) $ + fc & forestCursorSelectedTreeL (treeCursorInsert t) forestCursorInsertAndSelectTree :: - (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b + (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) + fromMaybe + (forestCursorInsertAndSelectTreeCursor f (makeTreeCursor g $ makeCTree t) fc) $ + fc & forestCursorSelectedTreeL (treeCursorInsertAndSelect f g t) forestCursorAppendTree :: Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAppendTree t fc = - fromMaybe (forestCursorAppendEntireTree t fc) $ - fc & forestCursorSelectedTreeL (treeCursorAppend t) + fromMaybe (forestCursorAppendEntireTree t fc) $ + fc & forestCursorSelectedTreeL (treeCursorAppend t) forestCursorAppendAndSelectTree :: - (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b + (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) + fromMaybe + (forestCursorAppendAndSelectTreeCursor f (makeTreeCursor g $ makeCTree t) fc) $ + fc & forestCursorSelectedTreeL (treeCursorAppendAndSelect f g t) forestCursorInsert :: b -> ForestCursor a b -> ForestCursor a b forestCursorInsert b = forestCursorInsertTree $ Node b [] forestCursorInsertAndSelect :: - (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b + (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b forestCursorInsertAndSelect f g b = - forestCursorInsertAndSelectTree f g $ Node b [] + forestCursorInsertAndSelectTree f g $ Node b [] 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 + (a -> b) -> (b -> a) -> b -> ForestCursor a b -> ForestCursor a b forestCursorAppendAndSelect f g b = - forestCursorAppendAndSelectTree f g $ Node b [] + forestCursorAppendAndSelectTree f g $ Node b [] forestCursorAddChildTreeToNodeAtPos :: - Int -> Tree b -> ForestCursor a b -> ForestCursor a b + Int -> Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildTreeToNodeAtPos i t = - forestCursorSelectedTreeL %~ treeCursorAddChildAtPos i t + forestCursorSelectedTreeL %~ treeCursorAddChildAtPos i t forestCursorAddChildTreeToNodeAtStart :: - Tree b -> ForestCursor a b -> ForestCursor a b + Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildTreeToNodeAtStart t = - forestCursorSelectedTreeL %~ treeCursorAddChildAtStart t + forestCursorSelectedTreeL %~ treeCursorAddChildAtStart t forestCursorAddChildTreeToNodeAtEnd :: - Tree b -> ForestCursor a b -> ForestCursor a b + Tree b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildTreeToNodeAtEnd t fc = - fc & forestCursorSelectedTreeL %~ treeCursorAddChildAtEnd t + fc & forestCursorSelectedTreeL %~ treeCursorAddChildAtEnd t forestCursorAddChildToNodeAtPos :: - Int -> b -> ForestCursor a b -> ForestCursor a b + Int -> b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildToNodeAtPos i b = - forestCursorAddChildTreeToNodeAtPos i $ Node b [] + forestCursorAddChildTreeToNodeAtPos i $ Node b [] forestCursorAddChildToNodeAtStart :: b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildToNodeAtStart b = - forestCursorAddChildTreeToNodeAtStart $ Node b [] + forestCursorAddChildTreeToNodeAtStart $ Node b [] forestCursorAddChildToNodeAtEnd :: b -> ForestCursor a b -> ForestCursor a b forestCursorAddChildToNodeAtEnd b = - forestCursorAddChildTreeToNodeAtEnd $ Node b [] + forestCursorAddChildTreeToNodeAtEnd $ Node b [] 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 - Just Deleted -> - (fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorRemoveElemAndSelectPrev (makeTreeCursor g))) - r -> r + case (fc & + focusPossibleDeleteOrUpdate + forestCursorSelectedTreeL + (treeCursorDeleteElemAndSelectPrevious g)) of + Just Deleted -> + (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 - Just Deleted -> - (fc & - focusPossibleDeleteOrUpdate - forestCursorListCursorL - (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g))) - r -> r + case (fc & + focusPossibleDeleteOrUpdate + forestCursorSelectedTreeL + (treeCursorDeleteElemAndSelectNext g)) of + Just Deleted -> + (fc & + focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g))) + r -> r forestCursorRemoveElem :: - (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) + (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) + (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))) + joinPossibleDeletes + (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))) + joinPossibleDeletes + (fc & + focusPossibleDeleteOrUpdate + forestCursorSelectedTreeL + (treeCursorDeleteSubTreeAndSelectNext g)) + (fc & + focusPossibleDeleteOrUpdate + forestCursorListCursorL + (nonEmptyCursorDeleteElemAndSelectNext (makeTreeCursor g))) forestCursorRemoveSubTree :: - (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) + (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) + (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 + (a -> b) -> (b -> a) -> ForestCursor a b -> a -> TreeCursor a b forestCursorAddRoot f g fc v = - makeTreeCursor g $ CNode (f v) $ OpenForest $ rebuildForestCursor f fc + makeTreeCursor g $ CNode (f v) $ OpenForest $ rebuildForestCursor f fc -- | Swaps the current node with the previous node on the same level -- @@ -430,19 +438,19 @@ -- > - a forestCursorSwapPrev :: ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSwapPrev fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL treeCursorSwapPrev of - Swapped fc' -> pure fc' - NoSiblingsToSwapWith -> Nothing - SwapperIsTopNode -> - case nonEmptyCursorPrev ne of - [] -> Nothing - (t:ts) -> - pure $ - ForestCursor - ne - { nonEmptyCursorPrev = ts - , nonEmptyCursorNext = t : nonEmptyCursorNext ne - } + case fc & forestCursorSelectedTreeL treeCursorSwapPrev of + Swapped fc' -> pure fc' + NoSiblingsToSwapWith -> Nothing + SwapperIsTopNode -> + case nonEmptyCursorPrev ne of + [] -> Nothing + (t:ts) -> + pure $ + ForestCursor + ne + { nonEmptyCursorPrev = ts + , nonEmptyCursorNext = t : nonEmptyCursorNext ne + } -- | Swaps the current node with the next node on the same level -- @@ -459,19 +467,19 @@ -- > - a <-- forestCursorSwapNext :: ForestCursor a b -> Maybe (ForestCursor a b) forestCursorSwapNext fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL treeCursorSwapNext of - Swapped fc' -> pure fc' - NoSiblingsToSwapWith -> Nothing - SwapperIsTopNode -> - case nonEmptyCursorNext ne of - [] -> Nothing - (t:ts) -> - pure $ - ForestCursor - ne - { nonEmptyCursorPrev = t : nonEmptyCursorPrev ne - , nonEmptyCursorNext = ts - } + case fc & forestCursorSelectedTreeL treeCursorSwapNext of + Swapped fc' -> pure fc' + NoSiblingsToSwapWith -> Nothing + SwapperIsTopNode -> + case nonEmptyCursorNext ne of + [] -> Nothing + (t:ts) -> + pure $ + ForestCursor + ne + { nonEmptyCursorPrev = t : nonEmptyCursorPrev ne + , nonEmptyCursorNext = ts + } -- | Promotes the current node to the level of its parent. -- @@ -499,44 +507,42 @@ -- > - d <-- -- > - h forestCursorPromoteElem :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorPromoteElem f g fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL (treeCursorPromoteElem f g) of - PromotedElem fc' -> pure fc' - CannotPromoteTopElem -> Nothing - NoSiblingsToAdoptChildren -> Nothing - NoGrandparentToPromoteElemUnder -> do - let tc = fc ^. forestCursorSelectedTreeL - ta <- treeAbove tc - lefts <- - case (treeBelow tc) of - EmptyCForest -> pure $ treeAboveLefts ta - _ -> - case treeAboveLefts ta of - [] -> Nothing - (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'} - tc'' <- - case treeCursorDeleteSubTree g tc' of - Deleted -> Nothing -- Cannot happen, otherwise we would have gotten 'CannotPromoteTopNode'. - Updated tc'' -> pure tc'' - pure $ - ForestCursor $ - ne - { nonEmptyCursorPrev = - rebuildTreeCursor f tc'' : nonEmptyCursorPrev ne - , nonEmptyCursorCurrent = - singletonTreeCursor $ - treeCurrent $ fc ^. forestCursorSelectedTreeL - } + case fc & forestCursorSelectedTreeL (treeCursorPromoteElem f g) of + PromotedElem fc' -> pure fc' + CannotPromoteTopElem -> Nothing + NoSiblingsToAdoptChildren -> Nothing + NoGrandparentToPromoteElemUnder -> do + let tc = fc ^. forestCursorSelectedTreeL + ta <- treeAbove tc + lefts <- + case (treeBelow tc) of + EmptyCForest -> pure $ treeAboveLefts ta + _ -> + case treeAboveLefts ta of + [] -> Nothing + (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'} + tc'' <- + case treeCursorDeleteSubTree g tc' of + Deleted -> Nothing -- Cannot happen, otherwise we would have gotten 'CannotPromoteTopNode'. + Updated tc'' -> pure tc'' + pure $ + ForestCursor $ + ne + { nonEmptyCursorPrev = + rebuildTreeCursor f tc'' : nonEmptyCursorPrev ne + , nonEmptyCursorCurrent = + singletonTreeCursor $ + treeCurrent $ fc ^. forestCursorSelectedTreeL + } -- | Promotes the current node to the level of its parent. -- @@ -565,24 +571,23 @@ -- > |- e -- > - h forestCursorPromoteSubTree :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorPromoteSubTree f g fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL (treeCursorPromoteSubTree f g) of - Promoted fc' -> pure fc' - CannotPromoteTopNode -> Nothing - NoGrandparentToPromoteUnder -> - case treeCursorDeleteSubTree g $ fc ^. forestCursorSelectedTreeL of - 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} - } + case fc & forestCursorSelectedTreeL (treeCursorPromoteSubTree f g) of + Promoted fc' -> pure fc' + CannotPromoteTopNode -> Nothing + NoGrandparentToPromoteUnder -> + case treeCursorDeleteSubTree g $ fc ^. forestCursorSelectedTreeL of + 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} + } -- | Demotes the current node to the level of its children. -- @@ -604,36 +609,31 @@ -- > |- d -- > - e forestCursorDemoteElem :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorDemoteElem f g fc@(ForestCursor ne) = - case (fc & forestCursorSelectedTreeL (treeCursorDemoteElem f g)) of - Demoted fc' -> pure fc' - CannotDemoteTopNode -> - case nonEmptyCursorPrev ne of - [] -> Nothing - (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' - tc <- - makeTreeCursorWithSelection - f - g - (SelectChild (lengthCForest vts) SelectNode) - n' - pure $ - ForestCursor - ne - { nonEmptyCursorPrev = ts - , nonEmptyCursorCurrent = tc - } - NoSiblingsToDemoteUnder -> Nothing + case (fc & forestCursorSelectedTreeL (treeCursorDemoteElem f g)) of + Demoted fc' -> pure fc' + CannotDemoteTopNode -> + case nonEmptyCursorPrev ne of + [] -> Nothing + (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' + tc <- + makeTreeCursorWithSelection + f + g + (SelectChild (lengthCForest vts) SelectNode) + n' + pure $ + ForestCursor + ne {nonEmptyCursorPrev = ts, nonEmptyCursorCurrent = tc} + NoSiblingsToDemoteUnder -> Nothing -- | Demotes the current subtree to the level of its children. -- @@ -653,35 +653,29 @@ -- > |- c <-- -- > |- d forestCursorDemoteSubTree :: - (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) forestCursorDemoteSubTree f g fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL (treeCursorDemoteSubTree f g) of - Demoted fc' -> pure fc' - CannotDemoteTopNode -> - case nonEmptyCursorPrev ne of - [] -> Nothing - (CNode v vts:ts) -> do - let n' = - CNode v $ - 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 + case fc & forestCursorSelectedTreeL (treeCursorDemoteSubTree f g) of + Demoted fc' -> pure fc' + CannotDemoteTopNode -> + case nonEmptyCursorPrev ne of + [] -> Nothing + (CNode v vts:ts) -> do + let n' = + CNode v $ + 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 -- | Demotes the current node to the level of its children, by adding two roots. -- One for the current node and one for its children that are left behind. @@ -701,28 +695,28 @@ -- > |- b forestCursorDemoteElemUnder :: b -> b -> ForestCursor a b -> ForestCursor a b forestCursorDemoteElemUnder b1 b2 fc@(ForestCursor ne) = - case fc & forestCursorSelectedTreeL (treeCursorDemoteElemUnder b1 b2) of - Just fc' -> fc' - 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 - } + case fc & forestCursorSelectedTreeL (treeCursorDemoteElemUnder b1 b2) of + Just fc' -> fc' + 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 + } -- | Demotes the current subtree to the level of its children, by adding a root. -- @@ -740,4 +734,14 @@ -- > |- b forestCursorDemoteSubTreeUnder :: b -> ForestCursor a b -> ForestCursor a b forestCursorDemoteSubTreeUnder b = - forestCursorSelectedTreeL %~ treeCursorDemoteSubTreeUnder b + forestCursorSelectedTreeL %~ treeCursorDemoteSubTreeUnder b + +traverseForestCursor :: + ([CTree b] -> TreeCursor a b -> [CTree b] -> f c) + -> ForestCursor a b + -> f c +traverseForestCursor = foldForestCursor + +foldForestCursor :: + ([CTree b] -> TreeCursor a b -> [CTree b] -> c) -> ForestCursor a b -> c +foldForestCursor func (ForestCursor ne) = foldNonEmptyCursor func ne diff --git a/src/Cursor/List.hs b/src/Cursor/List.hs --- a/src/Cursor/List.hs +++ b/src/Cursor/List.hs @@ -4,37 +4,43 @@ {-# 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 - ) where + ( 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 -data ListCursor a = ListCursor +import Cursor.Types + +data ListCursor a = + ListCursor { listCursorPrev :: [a] -- ^ In reverse order , listCursorNext :: [a] - } deriving (Show, Eq, Generic, Functor) + } + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (ListCursor a) @@ -46,14 +52,12 @@ makeListCursorWithSelection :: Int -> [a] -> Maybe (ListCursor a) makeListCursorWithSelection i as - | i < 0 = Nothing - | i > length as = Nothing - | otherwise = - Just - ListCursor - { listCursorPrev = reverse $ take i as - , listCursorNext = drop i as - } + | i < 0 = Nothing + | i > length as = Nothing + | otherwise = + Just + ListCursor + {listCursorPrev = reverse $ take i as, listCursorNext = drop i as} rebuildListCursor :: ListCursor a -> [a] rebuildListCursor ListCursor {..} = reverse listCursorPrev ++ listCursorNext @@ -69,56 +73,49 @@ listCursorSelectPrev :: ListCursor a -> Maybe (ListCursor a) listCursorSelectPrev tc = - case listCursorPrev tc of - [] -> Nothing - (c:cs) -> - Just - ListCursor - { listCursorPrev = cs - , listCursorNext = c : listCursorNext tc - } + case listCursorPrev tc of + [] -> Nothing + (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 - } + case listCursorNext tc of + [] -> Nothing + (c:cs) -> + Just + ListCursor {listCursorPrev = c : listCursorPrev tc, listCursorNext = cs} listCursorSelectIndex :: Int -> ListCursor a -> ListCursor a listCursorSelectIndex ix_ lc = - let ls = rebuildListCursor lc - in case splitAt ix_ ls of - (l, r) -> - ListCursor {listCursorPrev = reverse l, listCursorNext = r} + let ls = rebuildListCursor lc + in case splitAt ix_ ls of + (l, r) -> ListCursor {listCursorPrev = reverse l, listCursorNext = r} listCursorSelectStart :: ListCursor a -> ListCursor a listCursorSelectStart tc = - case listCursorSelectPrev tc of - Nothing -> tc - Just tc' -> listCursorSelectStart tc' + case listCursorSelectPrev tc of + Nothing -> tc + Just tc' -> listCursorSelectStart tc' listCursorSelectEnd :: ListCursor a -> ListCursor a listCursorSelectEnd tc = - case listCursorSelectNext tc of - Nothing -> tc - Just tc' -> listCursorSelectEnd tc' + case listCursorSelectNext tc of + Nothing -> tc + Just tc' -> listCursorSelectEnd tc' listCursorPrevItem :: ListCursor a -> Maybe a listCursorPrevItem lc = - case listCursorPrev lc of - [] -> Nothing - (c:_) -> Just c + case listCursorPrev lc of + [] -> Nothing + (c:_) -> Just c listCursorNextItem :: ListCursor a -> Maybe a listCursorNextItem lc = - case listCursorNext lc of - [] -> Nothing - (c:_) -> Just c + case listCursorNext lc of + [] -> Nothing + (c:_) -> Just c listCursorInsert :: a -> ListCursor a -> ListCursor a listCursorInsert c lc = lc {listCursorPrev = c : listCursorPrev lc} @@ -126,26 +123,39 @@ listCursorAppend :: a -> ListCursor a -> ListCursor a listCursorAppend c lc = lc {listCursorNext = c : listCursorNext lc} -listCursorRemove :: ListCursor a -> Maybe (ListCursor a) +listCursorRemove :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a)) listCursorRemove tc = - case listCursorPrev tc of - [] -> Nothing - (_:prev) -> Just $ tc {listCursorPrev = prev} + case listCursorPrev tc of + [] -> + case listCursorNext tc of + [] -> Just Deleted + _ -> Nothing + (_:prev) -> Just $ Updated $ tc {listCursorPrev = prev} -listCursorDelete :: ListCursor a -> Maybe (ListCursor a) +listCursorDelete :: ListCursor a -> Maybe (DeleteOrUpdate (ListCursor a)) listCursorDelete tc = - case listCursorNext tc of - [] -> Nothing - (_:next) -> Just $ tc {listCursorNext = next} + case listCursorNext tc of + [] -> + case listCursorPrev tc of + [] -> Just Deleted + _ -> Nothing + (_: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 - } + ListCursor + { listCursorPrev = reverse $ rebuildListCursor lc1 + , listCursorNext = rebuildListCursor lc2 + } + +traverseListCursor :: ([a] -> [a] -> f b) -> ListCursor a -> f b +traverseListCursor = foldListCursor + +foldListCursor :: ([a] -> [a] -> b) -> ListCursor a -> b +foldListCursor func ListCursor {..} = + func (reverse listCursorPrev) listCursorNext 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 @@ -4,36 +4,39 @@ {-# 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 - , nonemptyPrepend - , nonemptyAppend - ) where + ( 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) @@ -51,11 +54,13 @@ import Cursor.Types -- | A 'nonempty list' cursor -data NonEmptyCursor a b = NonEmptyCursor +data NonEmptyCursor a b = + NonEmptyCursor { nonEmptyCursorPrev :: [b] -- In reverse order , nonEmptyCursorCurrent :: a , nonEmptyCursorNext :: [b] - } deriving (Show, Eq, Generic, Functor) + } + deriving (Show, Eq, Generic, Functor) instance (Validity a, Validity b) => Validity (NonEmptyCursor a b) @@ -63,232 +68,239 @@ makeNonEmptyCursor g = fromJust . makeNonEmptyCursorWithSelection g 0 makeNonEmptyCursorWithSelection :: - (b -> a) -> Int -> NonEmpty b -> Maybe (NonEmptyCursor a b) + (b -> a) -> Int -> NonEmpty b -> Maybe (NonEmptyCursor a b) makeNonEmptyCursorWithSelection g i ne = do - (l, m, r) <- applyNonEmptySelection ne i - pure - NonEmptyCursor - { nonEmptyCursorPrev = reverse l - , nonEmptyCursorCurrent = g m - , nonEmptyCursorNext = r - } + (l, m, r) <- applyNonEmptySelection ne i + pure + NonEmptyCursor + { nonEmptyCursorPrev = reverse l + , nonEmptyCursorCurrent = g m + , nonEmptyCursorNext = r + } where applyNonEmptySelection :: NonEmpty a -> Int -> Maybe ([a], a, [a]) applyNonEmptySelection (c :| rest) i_ - | i_ < 0 = Nothing - | i_ == 0 = Just ([], c, rest) - | otherwise = do - ne_ <- NE.nonEmpty rest - (l, m, r) <- applyNonEmptySelection ne_ (i_ - 1) - pure (c : l, m, r) + | i_ < 0 = Nothing + | i_ == 0 = Just ([], c, rest) + | otherwise = do + ne_ <- NE.nonEmpty rest + (l, m, r) <- applyNonEmptySelection ne_ (i_ - 1) + pure (c : l, m, r) singletonNonEmptyCursor :: a -> NonEmptyCursor a b singletonNonEmptyCursor a = - NonEmptyCursor - { nonEmptyCursorPrev = [] - , nonEmptyCursorCurrent = a - , nonEmptyCursorNext = [] - } + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = a + , nonEmptyCursorNext = [] + } rebuildNonEmptyCursor :: (a -> b) -> NonEmptyCursor a b -> NonEmpty b rebuildNonEmptyCursor f NonEmptyCursor {..} = - nonemptyPrepend (reverse nonEmptyCursorPrev) $ - f nonEmptyCursorCurrent :| nonEmptyCursorNext + nonemptyPrepend (reverse nonEmptyCursorPrev) $ + f nonEmptyCursorCurrent :| nonEmptyCursorNext mapNonEmptyCursor :: - (a -> c) -> (b -> d) -> NonEmptyCursor a b -> NonEmptyCursor c d + (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 - } + NonEmptyCursor + { nonEmptyCursorPrev = map g nonEmptyCursorPrev + , nonEmptyCursorCurrent = f nonEmptyCursorCurrent + , nonEmptyCursorNext = map g nonEmptyCursorNext + } nonEmptyCursorElemL :: Lens (NonEmptyCursor a c) (NonEmptyCursor b c) a b nonEmptyCursorElemL = - lens nonEmptyCursorCurrent $ \lec le -> lec {nonEmptyCursorCurrent = le} + lens nonEmptyCursorCurrent $ \lec le -> lec {nonEmptyCursorCurrent = le} nonEmptyCursorSelectPrev :: - (a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) + (a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) nonEmptyCursorSelectPrev f g lec = - case nonEmptyCursorPrev lec of - [] -> Nothing - (e:rest) -> - Just $ - lec - { nonEmptyCursorPrev = rest - , nonEmptyCursorCurrent = g e - , nonEmptyCursorNext = - f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec - } + case nonEmptyCursorPrev lec of + [] -> Nothing + (e:rest) -> + Just $ + lec + { nonEmptyCursorPrev = rest + , nonEmptyCursorCurrent = g e + , nonEmptyCursorNext = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec + } nonEmptyCursorSelectNext :: - (a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) + (a -> b) -> (b -> a) -> NonEmptyCursor a b -> Maybe (NonEmptyCursor a b) nonEmptyCursorSelectNext f g lec = - case nonEmptyCursorNext lec of - [] -> Nothing - (e:rest) -> - Just $ - lec - { nonEmptyCursorPrev = - f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec - , nonEmptyCursorCurrent = g e - , nonEmptyCursorNext = rest - } + case nonEmptyCursorNext lec of + [] -> Nothing + (e:rest) -> + Just $ + lec + { nonEmptyCursorPrev = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec + , nonEmptyCursorCurrent = g e + , nonEmptyCursorNext = rest + } nonEmptyCursorSelectFirst :: - (a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorSelectFirst f g lec = - case nonEmptyCursorSelectPrev f g lec of - Nothing -> lec - Just lec' -> nonEmptyCursorSelectFirst f g lec' + case nonEmptyCursorSelectPrev f g lec of + Nothing -> lec + Just lec' -> nonEmptyCursorSelectFirst f g lec' nonEmptyCursorSelectLast :: - (a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> (b -> a) -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorSelectLast f g lec = - case nonEmptyCursorSelectNext f g lec of - Nothing -> lec - Just lec' -> nonEmptyCursorSelectLast f g lec' + case nonEmptyCursorSelectNext f g lec of + Nothing -> lec + Just lec' -> nonEmptyCursorSelectLast f g lec' nonEmptyCursorSelection :: NonEmptyCursor a b -> Int 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 - | i > nonEmptyCursorSelection nec = - nonEmptyCursorSelectNext f g nec >>= nonEmptyCursorSelectIndex f g i - | otherwise = Just nec + | i < nonEmptyCursorSelection nec = + nonEmptyCursorSelectPrev f g nec >>= nonEmptyCursorSelectIndex f g i + | i > nonEmptyCursorSelection nec = + nonEmptyCursorSelectNext f g nec >>= nonEmptyCursorSelectIndex f g i + | otherwise = Just nec nonEmptyCursorInsert :: b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorInsert c lec = - lec {nonEmptyCursorPrev = c : nonEmptyCursorPrev lec} + lec {nonEmptyCursorPrev = c : nonEmptyCursorPrev lec} nonEmptyCursorAppend :: b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorAppend c lec = - lec {nonEmptyCursorNext = c : nonEmptyCursorNext lec} + lec {nonEmptyCursorNext = c : nonEmptyCursorNext lec} nonEmptyCursorInsertAndSelect :: - (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorInsertAndSelect f c lec = - lec - { nonEmptyCursorCurrent = c - , nonEmptyCursorNext = - f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec - } + lec + { nonEmptyCursorCurrent = c + , nonEmptyCursorNext = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec + } nonEmptyCursorAppendAndSelect :: - (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b + (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorAppendAndSelect f c lec = - lec - { nonEmptyCursorCurrent = c - , nonEmptyCursorPrev = - f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec - } + lec + { nonEmptyCursorCurrent = c + , nonEmptyCursorPrev = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec + } nonEmptyCursorInsertAtStart :: b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorInsertAtStart c lec = - lec {nonEmptyCursorPrev = nonEmptyCursorPrev lec ++ [c]} + lec {nonEmptyCursorPrev = nonEmptyCursorPrev lec ++ [c]} nonEmptyCursorAppendAtEnd :: b -> NonEmptyCursor a b -> NonEmptyCursor a b nonEmptyCursorAppendAtEnd c lec = - lec {nonEmptyCursorNext = nonEmptyCursorNext lec ++ [c]} + 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 + 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 + 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} + case nonEmptyCursorPrev lec of + [] -> + case nonEmptyCursorNext lec of + [] -> Just Deleted + _ -> Nothing + (e:rest) -> + Just $ + Updated $ lec {nonEmptyCursorPrev = rest, nonEmptyCursorCurrent = g e} --- the first maybe: whether the operation succeeded --- the second maybe: whether the list is still nonempty 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} + case nonEmptyCursorNext lec of + [] -> + case nonEmptyCursorPrev lec of + [] -> Just Deleted + _ -> Nothing + (e:rest) -> + Just $ + Updated $ lec {nonEmptyCursorCurrent = g e, nonEmptyCursorNext = rest} nonEmptyCursorRemoveElem :: - (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) + (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) nonEmptyCursorRemoveElem g lec = - joinDeletes - (nonEmptyCursorRemoveElemAndSelectPrev g lec) - (nonEmptyCursorDeleteElemAndSelectNext g lec) + joinDeletes + (nonEmptyCursorRemoveElemAndSelectPrev g lec) + (nonEmptyCursorDeleteElemAndSelectNext g lec) nonEmptyCursorDeleteElem :: - (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) + (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) nonEmptyCursorDeleteElem g lec = - joinDeletes - (nonEmptyCursorDeleteElemAndSelectNext g lec) - (nonEmptyCursorRemoveElemAndSelectPrev g lec) + joinDeletes + (nonEmptyCursorDeleteElemAndSelectNext g lec) + (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 - else lookPrev nec `mplus` lookNext nec + if p $ nonEmptyCursorCurrent nec + then Just nec + else lookPrev nec `mplus` lookNext nec where lookPrev = look nonEmptyCursorSelectPrev lookNext = look nonEmptyCursorSelectNext look func nec_ = do - nec' <- func f g nec_ - if p $ nonEmptyCursorCurrent nec' - then Just nec' - else look func nec' + nec' <- func f g nec_ + if p $ nonEmptyCursorCurrent nec' + then Just nec' + 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 - Just nec' -> nec' + case nonEmptyCursorSearch f g p nec of + Nothing -> nonEmptyCursorAppendAndSelect f a nec + Just nec' -> nec' +renderNonEmptyCursor :: ([b] -> a -> [b] -> c) -> NonEmptyCursor a b -> c +renderNonEmptyCursor f NonEmptyCursor {..} = + f (reverse nonEmptyCursorPrev) nonEmptyCursorCurrent nonEmptyCursorNext + nonemptyPrepend :: [a] -> NonEmpty a -> NonEmpty a nonemptyPrepend ls ne = foldr (<|) ne ls nonemptyAppend :: NonEmpty a -> [a] -> NonEmpty a nonemptyAppend (x :| xs) ls = x :| (xs ++ ls) + +traverseNonEmptyCursor :: ([b] -> a -> [b] -> f c) -> NonEmptyCursor a b -> f c +traverseNonEmptyCursor = foldNonEmptyCursor + +foldNonEmptyCursor :: ([b] -> a -> [b] -> c) -> NonEmptyCursor a b -> c +foldNonEmptyCursor func NonEmptyCursor {..} = + func (reverse nonEmptyCursorPrev) nonEmptyCursorCurrent nonEmptyCursorNext diff --git a/src/Cursor/Map.hs b/src/Cursor/Map.hs --- a/src/Cursor/Map.hs +++ b/src/Cursor/Map.hs @@ -5,38 +5,40 @@ {-# 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 - , module Cursor.Map.KeyValue - ) where + ( 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) @@ -52,9 +54,11 @@ import Cursor.Map.KeyValue import Cursor.Types -newtype MapCursor kc vc k v = MapCursor +newtype MapCursor kc vc k v = + MapCursor { mapCursorList :: NonEmptyCursor (KeyValueCursor kc vc k v) (k, v) - } deriving (Show, Eq, Generic) + } + deriving (Show, Eq, Generic) instance (Validity kc, Validity vc, Validity k, Validity v) => Validity (MapCursor kc vc k v) @@ -63,119 +67,116 @@ makeMapCursor h = fromJust . makeMapCursorWithSelection h 0 makeMapCursorWithSelection :: - (k -> kc) -> Int -> NonEmpty (k, v) -> Maybe (MapCursor kc vc k v) + (k -> kc) -> Int -> NonEmpty (k, v) -> Maybe (MapCursor kc vc k v) makeMapCursorWithSelection h i ne = - MapCursor <$> - makeNonEmptyCursorWithSelection - (\(k, v) -> makeKeyValueCursorKey (h k) v) - i - ne + MapCursor <$> + makeNonEmptyCursorWithSelection + (\(k, v) -> makeKeyValueCursorKey (h k) v) + i + ne singletonMapCursorKey :: kc -> v -> MapCursor kc vc k v singletonMapCursorKey kc v = - MapCursor - {mapCursorList = singletonNonEmptyCursor $ makeKeyValueCursorKey kc v} + MapCursor + {mapCursorList = singletonNonEmptyCursor $ makeKeyValueCursorKey kc v} singletonMapCursorValue :: k -> vc -> MapCursor kc vc k v singletonMapCursorValue k vc = - MapCursor - {mapCursorList = singletonNonEmptyCursor $ makeKeyValueCursorValue k vc} + MapCursor + {mapCursorList = singletonNonEmptyCursor $ makeKeyValueCursorValue k vc} rebuildMapCursor :: - (kc -> k) -> (vc -> v) -> MapCursor kc vc k v -> NonEmpty (k, v) + (kc -> k) -> (vc -> v) -> MapCursor kc vc k v -> NonEmpty (k, v) rebuildMapCursor f g = - rebuildNonEmptyCursor (rebuildKeyValueCursor f g) . mapCursorList + 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 %~ + 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} + lens mapCursorList $ \mc ne -> mc {mapCursorList = ne} mapCursorElemL :: Lens' (MapCursor kc vc k v) (KeyValueCursor kc vc k v) mapCursorElemL = mapCursorNonEmptyCursorL . nonEmptyCursorElemL mapCursorSelectKey :: - (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v + (k -> kc) -> (vc -> v) -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorSelectKey g h = mapCursorElemL %~ keyValueCursorSelectKey g h mapCursorSelectValue :: - (kc -> k) -> (v -> vc) -> MapCursor kc vc k v -> MapCursor kc vc k v + (kc -> k) -> (v -> vc) -> MapCursor kc vc k v -> MapCursor kc vc k v 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 + 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) + 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) + 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)) + 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)) + mapCursorNonEmptyCursorL %~ (nonEmptyCursorSelectLast (rebuild f h) (make g)) mapCursorSelection :: MapCursor kc vc k v -> Int 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) + mapCursorNonEmptyCursorL (nonEmptyCursorSelectIndex (rebuild f h) (make g) i) mapCursorInsert :: k -> v -> MapCursor kc vc k v -> MapCursor kc vc k v mapCursorInsert k v = mapCursorNonEmptyCursorL %~ (nonEmptyCursorInsert (k, v)) @@ -184,104 +185,112 @@ 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) + focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ + 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) + focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ + nonEmptyCursorDeleteElemAndSelectNext (make g) mapCursorRemoveElem :: - (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) + (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) mapCursorRemoveElem g = - mapCursorNonEmptyCursorL $ nonEmptyCursorRemoveElem (make g) + mapCursorNonEmptyCursorL $ nonEmptyCursorRemoveElem (make g) mapCursorDeleteElem :: - (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) + (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) mapCursorDeleteElem g = - mapCursorNonEmptyCursorL $ nonEmptyCursorDeleteElem (make 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) + 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 f h = rebuildKeyValueCursor f h make :: (k -> kc) -> (k, v) -> KeyValueCursor kc vc k v 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 +traverseMapCursor combFunc = foldNonEmptyCursor combFunc . mapCursorList + +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 @@ -5,28 +5,28 @@ {-# LANGUAGE TypeFamilies #-} module Cursor.Map.KeyValue - ( KeyValueCursor(..) - , makeKeyValueCursorKey - , makeKeyValueCursorValue - , rebuildKeyValueCursor - , keyValueCursorSelection - , mapKeyValueCursor - , keyValueCursorSelectKey - , keyValueCursorSelectValue - , keyValueCursorToggleSelected - , KeyValueToggle(..) - ) where + ( KeyValueCursor(..) + , makeKeyValueCursorKey + , makeKeyValueCursorValue + , rebuildKeyValueCursor + , keyValueCursorSelection + , mapKeyValueCursor + , keyValueCursorSelectKey + , keyValueCursorSelectValue + , keyValueCursorToggleSelected + , KeyValueToggle(..) + , traverseKeyValueCursor + , foldKeyValueCursor + ) where import GHC.Generics (Generic) import Data.Validity data KeyValueCursor kc vc k v - = KeyValueCursorKey kc - v - | KeyValueCursorValue k - vc - deriving (Show, Eq, Generic) + = 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) @@ -38,7 +38,7 @@ makeKeyValueCursorValue = KeyValueCursorValue rebuildKeyValueCursor :: - (kc -> k) -> (vc -> v) -> KeyValueCursor kc vc k v -> (k, v) + (kc -> k) -> (vc -> v) -> KeyValueCursor kc vc k v -> (k, v) rebuildKeyValueCursor f _ (KeyValueCursorKey kc v) = (f kc, v) rebuildKeyValueCursor _ g (KeyValueCursorValue k vc) = (k, g vc) @@ -47,52 +47,63 @@ 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) + 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 + 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 + 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) - KeyValueCursorValue k vc -> KeyValueCursorKey (g k) (h vc) + case kvc of + KeyValueCursorKey kc v -> KeyValueCursorValue (f kc) (i v) + KeyValueCursorValue k vc -> KeyValueCursorKey (g k) (h vc) data KeyValueToggle - = KeySelected - | ValueSelected - deriving (Show, Eq, Generic) + = KeySelected + | ValueSelected + deriving (Show, Eq, Generic) instance Validity KeyValueToggle + +traverseKeyValueCursor :: + (kc -> v -> f c) -> (k -> vc -> f c) -> KeyValueCursor kc vc k v -> f c +traverseKeyValueCursor = foldKeyValueCursor + +foldKeyValueCursor :: + (kc -> v -> c) -> (k -> vc -> c) -> KeyValueCursor kc vc k v -> c +foldKeyValueCursor keyFunc valFunc kvc = + case kvc of + KeyValueCursorKey kc v -> keyFunc kc v + KeyValueCursorValue k vc -> valFunc k vc 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 @@ -4,75 +4,78 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Simple.Forest - ( ForestCursor - , makeForestCursor - , rebuildForestCursor - , FC.drawForestCursor - , mapForestCursor - , FC.forestCursorListCursorL - , FC.forestCursorSelectedTreeL - , forestCursorSelectPrevTreeCursor - , forestCursorSelectNextTreeCursor - , forestCursorSelectFirstTreeCursor - , forestCursorSelectLastTreeCursor - , forestCursorSelectPrev - , forestCursorSelectNext - , forestCursorSelectPrevOnSameLevel - , forestCursorSelectNextOnSameLevel - , forestCursorSelectFirst - , forestCursorSelectLast - , forestCursorSelectBelowAtPos - , forestCursorSelectBelowAtStart - , forestCursorSelectBelowAtEnd - , FC.forestCursorCloseCurrentForest - , FC.forestCursorOpenCurrentForest - , FC.forestCursorToggleCurrentForest - , 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 + ( 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 () @@ -124,6 +127,9 @@ forestCursorSelectLast :: ForestCursor a -> ForestCursor a forestCursorSelectLast = FC.forestCursorSelectLast id id +forestCursorSelectAbove :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectAbove = FC.forestCursorSelectAbove id id + forestCursorSelectBelowAtPos :: Int -> ForestCursor a -> Maybe (ForestCursor a) forestCursorSelectBelowAtPos = FC.forestCursorSelectBelowAtPos id id @@ -137,14 +143,14 @@ forestCursorSelectIndex = FC.forestCursorSelectIndex id id forestCursorInsertAndSelectTreeCursor :: - TreeCursor a -> ForestCursor a -> ForestCursor a + TreeCursor a -> ForestCursor a -> ForestCursor a forestCursorInsertAndSelectTreeCursor = - FC.forestCursorInsertAndSelectTreeCursor id + FC.forestCursorInsertAndSelectTreeCursor id forestCursorAppendAndSelectTreeCursor :: - TreeCursor a -> ForestCursor a -> ForestCursor a + TreeCursor a -> ForestCursor a -> ForestCursor a forestCursorAppendAndSelectTreeCursor = - FC.forestCursorAppendAndSelectTreeCursor id + FC.forestCursorAppendAndSelectTreeCursor id forestCursorInsertAndSelectTree :: Tree a -> ForestCursor a -> ForestCursor a forestCursorInsertAndSelectTree = FC.forestCursorInsertAndSelectTree id id @@ -159,11 +165,11 @@ forestCursorAppendAndSelect = FC.forestCursorAppendAndSelect id id forestCursorRemoveElemAndSelectPrev :: - ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) forestCursorRemoveElemAndSelectPrev = FC.forestCursorRemoveElemAndSelectPrev id forestCursorDeleteElemAndSelectNext :: - ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) forestCursorDeleteElemAndSelectNext = FC.forestCursorDeleteElemAndSelectNext id forestCursorRemoveElem :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) @@ -173,14 +179,14 @@ forestCursorDeleteElem = FC.forestCursorDeleteElem id forestCursorRemoveSubTreeAndSelectPrev :: - ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) forestCursorRemoveSubTreeAndSelectPrev = - FC.forestCursorRemoveSubTreeAndSelectPrev id + FC.forestCursorRemoveSubTreeAndSelectPrev id forestCursorDeleteSubTreeAndSelectNext :: - ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) forestCursorDeleteSubTreeAndSelectNext = - FC.forestCursorDeleteSubTreeAndSelectNext id + FC.forestCursorDeleteSubTreeAndSelectNext id forestCursorRemoveSubTree :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) forestCursorRemoveSubTree = FC.forestCursorRemoveSubTree 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 @@ -4,37 +4,37 @@ {-# LANGUAGE DeriveFunctor #-} 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 + ( 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(..)) @@ -79,36 +79,36 @@ nonEmptyCursorAppendAndSelect = NEC.nonEmptyCursorAppendAndSelect id nonEmptyCursorInsertAtStartAndSelect :: - a -> NonEmptyCursor a -> NonEmptyCursor a + a -> NonEmptyCursor a -> NonEmptyCursor a nonEmptyCursorInsertAtStartAndSelect = - NEC.nonEmptyCursorInsertAtStartAndSelect id id + NEC.nonEmptyCursorInsertAtStartAndSelect id id nonEmptyCursorAppendAtEndAndSelect :: a -> NonEmptyCursor a -> NonEmptyCursor a nonEmptyCursorAppendAtEndAndSelect = - NEC.nonEmptyCursorAppendAtEndAndSelect id id + NEC.nonEmptyCursorAppendAtEndAndSelect id id nonEmptyCursorRemoveElemAndSelectPrev :: - NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) nonEmptyCursorRemoveElemAndSelectPrev = - NEC.nonEmptyCursorRemoveElemAndSelectPrev id + NEC.nonEmptyCursorRemoveElemAndSelectPrev id nonEmptyCursorDeleteElemAndSelectNext :: - NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) nonEmptyCursorDeleteElemAndSelectNext = - NEC.nonEmptyCursorDeleteElemAndSelectNext id + NEC.nonEmptyCursorDeleteElemAndSelectNext id nonEmptyCursorRemoveElem :: - NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) + NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) nonEmptyCursorRemoveElem = NEC.nonEmptyCursorRemoveElem id nonEmptyCursorDeleteElem :: - NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) + NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) nonEmptyCursorDeleteElem = NEC.nonEmptyCursorDeleteElem id nonEmptyCursorSearch :: - (a -> Bool) -> NonEmptyCursor a -> Maybe (NonEmptyCursor a) + (a -> Bool) -> NonEmptyCursor a -> Maybe (NonEmptyCursor a) nonEmptyCursorSearch = NEC.nonEmptyCursorSearch id id nonEmptyCursorSelectOrAdd :: - (a -> Bool) -> a -> NonEmptyCursor a -> NonEmptyCursor a + (a -> Bool) -> a -> NonEmptyCursor a -> NonEmptyCursor a nonEmptyCursorSelectOrAdd = NEC.nonEmptyCursorSelectOrAdd id id 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 @@ -5,39 +5,39 @@ {-# 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 + ( 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(..)) @@ -96,11 +96,11 @@ mapCursorAppendAndSelectValue = MC.mapCursorAppendAndSelectValue id id mapCursorRemoveElemAndSelectPrev :: - MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) + MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) mapCursorRemoveElemAndSelectPrev = MC.mapCursorRemoveElemAndSelectPrev id mapCursorDeleteElemAndSelectNext :: - MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) + MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) mapCursorDeleteElemAndSelectNext = MC.mapCursorDeleteElemAndSelectNext id mapCursorRemoveElem :: MapCursor k v -> DeleteOrUpdate (MapCursor k v) @@ -113,5 +113,5 @@ mapCursorSearch = MC.mapCursorSearch id id id mapCursorSelectOrAdd :: - (k -> v -> Bool) -> KeyValueCursor k v -> MapCursor k v -> MapCursor k v + (k -> v -> Bool) -> KeyValueCursor k v -> MapCursor k v -> MapCursor k v mapCursorSelectOrAdd = MC.mapCursorSelectOrAdd id id id 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,19 @@ {-# 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 @@ -23,7 +23,7 @@ rebuildKeyValueCursor = KVC.rebuildKeyValueCursor id id mapKeyValueCursor :: - (k -> l) -> (v -> w) -> KeyValueCursor k v -> KeyValueCursor l w + (k -> l) -> (v -> w) -> KeyValueCursor k v -> KeyValueCursor l w mapKeyValueCursor f g = KVC.mapKeyValueCursor f g f g keyValueCursorSelectKey :: KeyValueCursor k v -> KeyValueCursor k v 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 @@ -4,77 +4,79 @@ {-# LANGUAGE DeriveFunctor #-} 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.treeCursorCloseCurrentForest - , TC.treeCursorOpenCurrentForest - , TC.treeCursorToggleCurrentForest - , 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 + ( 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 @@ -89,7 +91,7 @@ makeTreeCursor = TC.makeTreeCursor id makeTreeCursorWithSelection :: - TC.TreeCursorSelection -> CTree a -> Maybe (TreeCursor a) + TC.TreeCursorSelection -> CTree a -> Maybe (TreeCursor a) makeTreeCursorWithSelection = TC.makeTreeCursorWithSelection id id singletonTreeCursor :: a -> TreeCursor a @@ -102,7 +104,7 @@ mapTreeCursor f = TC.mapTreeCursor f f treeCursorSelect :: - TC.TreeCursorSelection -> TreeCursor a -> Maybe (TreeCursor a) + TC.TreeCursorSelection -> TreeCursor a -> Maybe (TreeCursor a) treeCursorSelect = TC.treeCursorSelect id id treeCursorSelectPrev :: TreeCursor a -> Maybe (TreeCursor a) @@ -131,11 +133,11 @@ treeCursorSelectBelowAtStartRecursively :: TreeCursor a -> Maybe (TreeCursor a) treeCursorSelectBelowAtStartRecursively = - TC.treeCursorSelectBelowAtStartRecursively id id + TC.treeCursorSelectBelowAtStartRecursively id id treeCursorSelectBelowAtEndRecursively :: TreeCursor a -> Maybe (TreeCursor a) treeCursorSelectBelowAtEndRecursively = - TC.treeCursorSelectBelowAtEndRecursively id id + TC.treeCursorSelectBelowAtEndRecursively id id treeCursorSelectPrevOnSameLevel :: TreeCursor a -> Maybe (TreeCursor a) treeCursorSelectPrevOnSameLevel = TC.treeCursorSelectPrevOnSameLevel id id @@ -160,19 +162,19 @@ treeCursorAppendAndSelect = TC.treeCursorAppendAndSelect id id treeCursorDeleteSubTreeAndSelectPrevious :: - TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteSubTreeAndSelectPrevious = - TC.treeCursorDeleteSubTreeAndSelectPrevious id + TC.treeCursorDeleteSubTreeAndSelectPrevious id treeCursorDeleteSubTreeAndSelectNext :: - TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteSubTreeAndSelectNext = - TC.treeCursorDeleteSubTreeAndSelectNext id + TC.treeCursorDeleteSubTreeAndSelectNext id treeCursorDeleteSubTreeAndSelectAbove :: - TreeCursor a -> DeleteOrUpdate (TreeCursor a) + TreeCursor a -> DeleteOrUpdate (TreeCursor a) treeCursorDeleteSubTreeAndSelectAbove = - TC.treeCursorDeleteSubTreeAndSelectAbove id + TC.treeCursorDeleteSubTreeAndSelectAbove id treeCursorRemoveSubTree :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) treeCursorRemoveSubTree = TC.treeCursorRemoveSubTree id @@ -181,16 +183,16 @@ treeCursorDeleteSubTree = TC.treeCursorDeleteSubTree id treeCursorDeleteElemAndSelectPrevious :: - TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteElemAndSelectPrevious = - TC.treeCursorDeleteElemAndSelectPrevious id + TC.treeCursorDeleteElemAndSelectPrevious id treeCursorDeleteElemAndSelectNext :: - TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteElemAndSelectNext = TC.treeCursorDeleteElemAndSelectNext id treeCursorDeleteElemAndSelectAbove :: - TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) treeCursorDeleteElemAndSelectAbove = TC.treeCursorDeleteElemAndSelectAbove id treeCursorRemoveElem :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) diff --git a/src/Cursor/Text.hs b/src/Cursor/Text.hs --- a/src/Cursor/Text.hs +++ b/src/Cursor/Text.hs @@ -3,28 +3,28 @@ {-# 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 + ( 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) @@ -35,19 +35,22 @@ import Lens.Micro import Cursor.List +import Cursor.Types -- | A cursor for single-line texts -newtype TextCursor = TextCursor +newtype TextCursor = + TextCursor { textCursorList :: ListCursor Char - } deriving (Show, Eq, Generic) + } + deriving (Show, Eq, Generic) instance Validity TextCursor where - validate (TextCursor lc) = - mconcat - [ genericValidate lc - , decorateList (rebuildListCursor lc) $ \c -> - declare "The character is not a newline character" $ c /= '\n' - ] + validate (TextCursor lc) = + mconcat + [ genericValidate lc + , decorateList (rebuildListCursor lc) $ \c -> + declare "The character is not a newline character" $ c /= '\n' + ] emptyTextCursor :: TextCursor emptyTextCursor = TextCursor emptyListCursor @@ -57,18 +60,18 @@ makeTextCursorWithSelection :: Int -> Text -> Maybe TextCursor makeTextCursorWithSelection i t = - case T.split (== '\n') t of - [l] -> TextCursor <$> makeListCursorWithSelection i (T.unpack l) - _ -> Nothing + case T.split (== '\n') t of + [l] -> TextCursor <$> makeListCursorWithSelection i (T.unpack l) + _ -> Nothing rebuildTextCursor :: TextCursor -> Text 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 @@ -109,17 +112,19 @@ textCursorAppend '\n' _ = Nothing textCursorAppend c tc = Just (tc & textCursorListCursorL %~ listCursorAppend c) -textCursorRemove :: TextCursor -> Maybe TextCursor -textCursorRemove = textCursorListCursorL listCursorRemove +textCursorRemove :: TextCursor -> Maybe (DeleteOrUpdate TextCursor) +textCursorRemove = + focusPossibleDeleteOrUpdate textCursorListCursorL listCursorRemove -textCursorDelete :: TextCursor -> Maybe TextCursor -textCursorDelete = textCursorListCursorL listCursorDelete +textCursorDelete :: TextCursor -> Maybe (DeleteOrUpdate TextCursor) +textCursorDelete = + focusPossibleDeleteOrUpdate textCursorListCursorL listCursorDelete textCursorSplit :: TextCursor -> (TextCursor, TextCursor) textCursorSplit tc = - let (lc1, lc2) = listCursorSplit $ textCursorList tc - in (TextCursor lc1, TextCursor lc2) + let (lc1, lc2) = listCursorSplit $ textCursorList tc + in (TextCursor lc1, TextCursor lc2) textCursorCombine :: TextCursor -> TextCursor -> TextCursor textCursorCombine (TextCursor lc1) (TextCursor lc2) = - TextCursor {textCursorList = listCursorCombine lc1 lc2} + TextCursor {textCursorList = listCursorCombine lc1 lc2} diff --git a/src/Cursor/TextField.hs b/src/Cursor/TextField.hs --- a/src/Cursor/TextField.hs +++ b/src/Cursor/TextField.hs @@ -4,33 +4,33 @@ {-# 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 + ( 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) @@ -51,120 +51,119 @@ import Cursor.Text import Cursor.Types -newtype TextFieldCursor = TextFieldCursor +newtype TextFieldCursor = + TextFieldCursor { textFieldCursorNonEmpty :: NonEmptyCursor TextCursor Text - } deriving (Show, Eq, Generic) + } + deriving (Show, Eq, Generic) instance Validity TextFieldCursor where - validate tfc@TextFieldCursor {..} = - mconcat - [ genericValidate tfc - , decorate "None of the texts contain newlines" $ - mconcat $ - NE.toList $ - flip - NE.map - (NE.zip (fromJust $ NE.nonEmpty [0 ..]) $ - rebuildNonEmptyCursor - rebuildTextCursor - textFieldCursorNonEmpty) $ \(i, tc) -> - declare - (unwords - [ "The text of the line at index" - , show (i :: Int) - , "does not contain any newlines" - ]) $ - T.all (/= '\n') tc - ] + validate tfc@TextFieldCursor {..} = + mconcat + [ genericValidate tfc + , decorate "None of the texts contain newlines" $ + mconcat $ + NE.toList $ + flip + NE.map + (NE.zip (fromJust $ NE.nonEmpty [0 ..]) $ + rebuildNonEmptyCursor rebuildTextCursor textFieldCursorNonEmpty) $ \(i, tc) -> + declare + (unwords + [ "The text of the line at index" + , show (i :: Int) + , "does not contain any newlines" + ]) $ + T.all (/= '\n') tc + ] makeTextFieldCursor :: Text -> TextFieldCursor makeTextFieldCursor = fromJust . makeTextFieldCursorWithSelection 0 0 makeTextFieldCursorWithSelection :: Int -> Int -> Text -> Maybe TextFieldCursor makeTextFieldCursorWithSelection x y t = do - let ls + let ls -- This is safe because 'splitOn' always returns a nonempty list. - = NE.fromList $ T.split (== '\n') t - guard (x >= 0) - guard (x < NE.length ls) - nec <- - makeNonEmptyCursorWithSelection + = NE.fromList $ T.split (== '\n') t + guard (x >= 0) + guard (x < NE.length ls) + nec <- + makeNonEmptyCursorWithSelection -- This is safe because we already checked that it would work above - (makeTextCursorWithSelection y) - x - ls - void $ nonEmptyCursorCurrent nec - pure $ TextFieldCursor (nec & nonEmptyCursorElemL %~ fromJust) + (makeTextCursorWithSelection y) + x + ls + void $ nonEmptyCursorCurrent nec + pure $ TextFieldCursor (nec & nonEmptyCursorElemL %~ fromJust) rebuildTextFieldCursorLines :: TextFieldCursor -> NonEmpty Text rebuildTextFieldCursorLines = - rebuildNonEmptyCursor rebuildTextCursor . textFieldCursorNonEmpty + rebuildNonEmptyCursor rebuildTextCursor . textFieldCursorNonEmpty rebuildTextFieldCursor :: TextFieldCursor -> Text rebuildTextFieldCursor = - T.intercalate "\n" . NE.toList . rebuildTextFieldCursorLines + T.intercalate "\n" . NE.toList . rebuildTextFieldCursorLines emptyTextFieldCursor :: TextFieldCursor emptyTextFieldCursor = - TextFieldCursor - {textFieldCursorNonEmpty = singletonNonEmptyCursor emptyTextCursor} + TextFieldCursor + {textFieldCursorNonEmpty = singletonNonEmptyCursor emptyTextCursor} nullTextFieldCursor :: TextFieldCursor -> Bool nullTextFieldCursor = (== emptyTextFieldCursor) 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) + Lens' TextFieldCursor (NonEmptyCursor TextCursor Text) textFieldCursorNonEmptyCursorL = - lens textFieldCursorNonEmpty $ \tfc lec -> - tfc {textFieldCursorNonEmpty = lec} + lens textFieldCursorNonEmpty $ \tfc lec -> tfc {textFieldCursorNonEmpty = lec} textFieldCursorSelectedL :: Lens' TextFieldCursor TextCursor textFieldCursorSelectedL = textFieldCursorNonEmptyCursorL . nonEmptyCursorElemL textFieldCursorSelectPrevLine :: TextFieldCursor -> Maybe TextFieldCursor textFieldCursorSelectPrevLine = - moveMWhileKeepingSelection $ - nonEmptyCursorSelectPrev rebuildTextCursor unsafeMakeTextCursor + moveMWhileKeepingSelection $ + nonEmptyCursorSelectPrev rebuildTextCursor unsafeMakeTextCursor textFieldCursorSelectNextLine :: TextFieldCursor -> Maybe TextFieldCursor textFieldCursorSelectNextLine = - moveMWhileKeepingSelection $ - nonEmptyCursorSelectNext rebuildTextCursor unsafeMakeTextCursor + 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 - tfc'' <- textFieldCursorNonEmptyCursorL movement $ tfc' - pure $ textFieldCursorSelectIndexOnLine i tfc'' + let i = textFieldCursorIndexOnLine tfc + let tfc' = textFieldCursorSelectIndexOnLine 0 tfc + tfc'' <- textFieldCursorNonEmptyCursorL movement $ tfc' + pure $ textFieldCursorSelectIndexOnLine i tfc'' textFieldCursorSelectFirstLine :: TextFieldCursor -> TextFieldCursor textFieldCursorSelectFirstLine = - moveWhileKeepingSelection $ - nonEmptyCursorSelectFirst rebuildTextCursor unsafeMakeTextCursor + moveWhileKeepingSelection $ + nonEmptyCursorSelectFirst rebuildTextCursor unsafeMakeTextCursor textFieldCursorSelectLastLine :: TextFieldCursor -> TextFieldCursor textFieldCursorSelectLastLine = - moveWhileKeepingSelection $ - nonEmptyCursorSelectLast rebuildTextCursor unsafeMakeTextCursor + 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 - tfc'' = tfc' & textFieldCursorNonEmptyCursorL %~ movement - in textFieldCursorSelectIndexOnLine i tfc'' + let i = textFieldCursorIndexOnLine tfc + tfc' = textFieldCursorSelectIndexOnLine 0 tfc + tfc'' = tfc' & textFieldCursorNonEmptyCursorL %~ movement + in textFieldCursorSelectIndexOnLine i tfc'' textFieldCursorSelectPrevChar :: TextFieldCursor -> Maybe TextFieldCursor textFieldCursorSelectPrevChar = textFieldCursorSelectedL textCursorSelectPrev @@ -174,109 +173,107 @@ textFieldCursorIndexOnLine :: TextFieldCursor -> Int textFieldCursorIndexOnLine tfc = - textCursorIndex $ tfc ^. textFieldCursorSelectedL + textCursorIndex $ tfc ^. textFieldCursorSelectedL textFieldCursorSelectIndexOnLine :: Int -> TextFieldCursor -> TextFieldCursor textFieldCursorSelectIndexOnLine ix_ = - textFieldCursorSelectedL %~ textCursorSelectIndex ix_ + textFieldCursorSelectedL %~ textCursorSelectIndex ix_ textFieldCursorInsertChar :: Char -> Maybe TextFieldCursor -> TextFieldCursor textFieldCursorInsertChar c mtfc = - case c of - '\n' -> textFieldCursorInsertNewline mtfc - _ -> - (fromMaybe emptyTextFieldCursor mtfc) & - textFieldCursorSelectedL %~ (fromJust . textCursorInsert c) + case c of + '\n' -> textFieldCursorInsertNewline mtfc + _ -> + (fromMaybe emptyTextFieldCursor mtfc) & + textFieldCursorSelectedL %~ (fromJust . textCursorInsert c) textFieldCursorAppendChar :: Char -> Maybe TextFieldCursor -> TextFieldCursor textFieldCursorAppendChar c mtfc = - case c of - '\n' -> textFieldCursorAppendNewline mtfc - _ -> - (fromMaybe emptyTextFieldCursor mtfc) & - textFieldCursorSelectedL %~ (fromJust . textCursorAppend c) + case c of + '\n' -> textFieldCursorAppendNewline mtfc + _ -> + (fromMaybe emptyTextFieldCursor mtfc) & + textFieldCursorSelectedL %~ (fromJust . textCursorAppend c) 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 - }) + let tfc = fromMaybe emptyTextFieldCursor mtfc + 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 - }) + let tfc = fromMaybe emptyTextFieldCursor mtfc + in tfc & + textFieldCursorNonEmptyCursorL %~ + (\lec@NonEmptyCursor {..} -> + let (tc1, tc2) = textCursorSplit nonEmptyCursorCurrent + in lec + { nonEmptyCursorCurrent = tc1 + , nonEmptyCursorNext = rebuildTextCursor tc2 : nonEmptyCursorNext + }) textFieldCursorRemove :: - TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) + TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) textFieldCursorRemove tfc = - if nullTextFieldCursor tfc - then Just Deleted - else focusPossibleDeleteOrUpdate - textFieldCursorNonEmptyCursorL - (\lec@NonEmptyCursor {..} -> - case textCursorRemove nonEmptyCursorCurrent of - Nothing -> - case nonEmptyCursorPrev of - [] -> Nothing - (pl:pls) -> - Just $ - Updated $ - lec - { nonEmptyCursorPrev = pls - , nonEmptyCursorCurrent = - textCursorCombine - (unsafeMakeTextCursor pl) - nonEmptyCursorCurrent - } - Just ctc -> - Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc) - 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 $ + Updated $ + lec + { nonEmptyCursorPrev = pls + , nonEmptyCursorCurrent = + textCursorCombine + (unsafeMakeTextCursor pl) + nonEmptyCursorCurrent + }) + tfc textFieldCursorDelete :: - TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) + TextFieldCursor -> Maybe (DeleteOrUpdate TextFieldCursor) textFieldCursorDelete tfc = - if nullTextFieldCursor tfc - then Just Deleted - else focusPossibleDeleteOrUpdate - textFieldCursorNonEmptyCursorL - (\lec@NonEmptyCursor {..} -> - case textCursorDelete nonEmptyCursorCurrent of - Nothing -> - case nonEmptyCursorNext of - [] -> Nothing - (pl:pls) -> - Just $ - Updated $ - lec - { nonEmptyCursorCurrent = - textCursorCombine - nonEmptyCursorCurrent - (unsafeMakeTextCursor pl) - , nonEmptyCursorNext = pls - } - Just ctc -> - Just $ Updated $ lec & nonEmptyCursorElemL .~ ctc) - 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 $ + Updated $ + lec + { nonEmptyCursorCurrent = + textCursorCombine + nonEmptyCursorCurrent + (unsafeMakeTextCursor pl) + , nonEmptyCursorNext = pls + }) + tfc textFieldCursorSelectStartOfLine :: TextFieldCursor -> TextFieldCursor textFieldCursorSelectStartOfLine = - textFieldCursorSelectedL %~ textCursorSelectStart + textFieldCursorSelectedL %~ textCursorSelectStart textFieldCursorSelectEndOfLine :: TextFieldCursor -> TextFieldCursor textFieldCursorSelectEndOfLine = textFieldCursorSelectedL %~ textCursorSelectEnd diff --git a/src/Cursor/Tree.hs b/src/Cursor/Tree.hs --- a/src/Cursor/Tree.hs +++ b/src/Cursor/Tree.hs @@ -1,36 +1,36 @@ {-# 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 import Cursor.Tree.Delete import Cursor.Tree.Demote import Cursor.Tree.Draw import Cursor.Tree.Insert -import Cursor.Tree.Collapse import Cursor.Tree.Movement import Cursor.Tree.Promote import Cursor.Tree.Swap 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 @@ -1,65 +1,70 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Base - ( singletonTreeCursor - , makeTreeCursor - , makeTreeCursorWithSelection - , rebuildTreeCursor - , mapTreeCursor - , currentTree - , makeTreeCursorWithAbove - ) where + ( singletonTreeCursor + , makeTreeCursor + , makeTreeCursorWithSelection + , rebuildTreeCursor + , mapTreeCursor + , currentTree + , makeTreeCursorWithAbove + , traverseTreeCursor + , foldTreeCursor + ) where +import Control.Monad + import Cursor.Tree.Types singletonTreeCursor :: a -> TreeCursor a b singletonTreeCursor v = - TreeCursor {treeAbove = Nothing, treeCurrent = v, treeBelow = emptyCForest} + TreeCursor {treeAbove = Nothing, treeCurrent = v, treeBelow = emptyCForest} makeTreeCursor :: (b -> a) -> CTree b -> TreeCursor a b makeTreeCursor g (CNode v fs) = - TreeCursor {treeAbove = Nothing, treeCurrent = g v, treeBelow = fs} + TreeCursor {treeAbove = Nothing, treeCurrent = g 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 - } + (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 + } rebuildTreeCursor :: (a -> b) -> TreeCursor a b -> CTree b rebuildTreeCursor f TreeCursor {..} = - wrapAbove treeAbove $ CNode (f treeCurrent) treeBelow + wrapAbove treeAbove $ CNode (f treeCurrent) treeBelow where wrapAbove Nothing t = t wrapAbove (Just TreeAbove {..}) t = - wrapAbove treeAboveAbove $ - CNode treeAboveNode $ - openForest $ concat [reverse treeAboveLefts, [t], treeAboveRights] + wrapAbove treeAboveAbove $ + CNode treeAboveNode $ + openForest $ concat [reverse treeAboveLefts, [t], treeAboveRights] mapTreeCursor :: (a -> c) -> (b -> d) -> TreeCursor a b -> TreeCursor c d mapTreeCursor f g TreeCursor {..} = - TreeCursor + TreeCursor { treeAbove = fmap g <$> treeAbove , treeCurrent = f treeCurrent , treeBelow = fmap g treeBelow @@ -69,6 +74,40 @@ currentTree f TreeCursor {..} = CNode (f treeCurrent) treeBelow makeTreeCursorWithAbove :: - (b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b + (b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b makeTreeCursorWithAbove g (CNode a forest) mta = - TreeCursor {treeAbove = mta, treeCurrent = g a, treeBelow = forest} + 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 +traverseTreeCursor wrapFunc currentFunc TreeCursor {..} = + currentFunc treeCurrent treeBelow >>= wrapAbove treeAbove + where + wrapAbove :: Maybe (TreeAbove b) -> c -> m c + wrapAbove Nothing = pure + wrapAbove (Just ta) = goAbove ta + goAbove :: TreeAbove b -> c -> m c + goAbove TreeAbove {..} = + 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 +foldTreeCursor wrapFunc currentFunc TreeCursor {..} = + wrapAbove treeAbove $ currentFunc treeCurrent treeBelow + where + wrapAbove :: Maybe (TreeAbove b) -> c -> c + wrapAbove Nothing = id + wrapAbove (Just ta) = goAbove ta + goAbove :: TreeAbove b -> c -> c + goAbove TreeAbove {..} = + wrapAbove treeAboveAbove . + wrapFunc (reverse treeAboveLefts) treeAboveNode treeAboveRights 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,8 +1,10 @@ module Cursor.Tree.Collapse - ( treeCursorCloseCurrentForest - , treeCursorOpenCurrentForest - , treeCursorToggleCurrentForest - ) where + ( treeCursorOpenCurrentForest + , treeCursorCloseCurrentForest + , treeCursorToggleCurrentForest + , treeCursorOpenCurrentForestRecursively + , treeCursorToggleCurrentForestRecursively + ) where import qualified Data.List.NonEmpty as NE @@ -10,25 +12,42 @@ treeCursorOpenCurrentForest :: TreeCursor a b -> Maybe (TreeCursor a b) treeCursorOpenCurrentForest tc = - case treeBelow tc of - EmptyCForest -> Nothing - ClosedForest ts -> - Just $ tc {treeBelow = OpenForest $ NE.map makeCTree ts} - OpenForest _ -> Nothing + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest ts -> Just $ tc {treeBelow = OpenForest $ NE.map makeCTree ts} + OpenForest _ -> Nothing treeCursorCloseCurrentForest :: TreeCursor a b -> Maybe (TreeCursor a b) treeCursorCloseCurrentForest tc = - case treeBelow tc of - EmptyCForest -> Nothing - ClosedForest _ -> Nothing - OpenForest ts -> - Just $ tc {treeBelow = ClosedForest $ NE.map rebuildCTree ts} + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest _ -> Nothing + OpenForest ts -> + Just $ tc {treeBelow = ClosedForest $ NE.map rebuildCTree ts} treeCursorToggleCurrentForest :: TreeCursor a b -> Maybe (TreeCursor a b) treeCursorToggleCurrentForest tc = - case treeBelow tc of - EmptyCForest -> Nothing - ClosedForest ts -> - Just $ tc {treeBelow = OpenForest $ NE.map makeCTree ts} - OpenForest ts -> - Just $ tc {treeBelow = ClosedForest $ NE.map rebuildCTree ts} + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest ts -> Just $ tc {treeBelow = OpenForest $ NE.map makeCTree ts} + OpenForest ts -> + Just $ tc {treeBelow = ClosedForest $ NE.map rebuildCTree ts} + +treeCursorOpenCurrentForestRecursively :: + TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorOpenCurrentForestRecursively tc = + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest ts -> + Just $ tc {treeBelow = OpenForest $ NE.map (cTree True) ts} + OpenForest _ -> Nothing + +treeCursorToggleCurrentForestRecursively :: + TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorToggleCurrentForestRecursively tc = + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest ts -> + Just $ tc {treeBelow = OpenForest $ NE.map (cTree True) ts} + OpenForest ts -> + Just $ tc {treeBelow = ClosedForest $ NE.map rebuildCTree ts} 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 @@ -4,17 +4,17 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Delete - ( treeCursorDeleteSubTreeAndSelectPrevious - , treeCursorDeleteSubTreeAndSelectNext - , treeCursorDeleteSubTreeAndSelectAbove - , treeCursorRemoveSubTree - , treeCursorDeleteSubTree - , treeCursorDeleteElemAndSelectPrevious - , treeCursorDeleteElemAndSelectNext - , treeCursorDeleteElemAndSelectAbove - , treeCursorRemoveElem - , treeCursorDeleteElem - ) where + ( treeCursorDeleteSubTreeAndSelectPrevious + , treeCursorDeleteSubTreeAndSelectNext + , treeCursorDeleteSubTreeAndSelectAbove + , treeCursorRemoveSubTree + , treeCursorDeleteSubTree + , treeCursorDeleteElemAndSelectPrevious + , treeCursorDeleteElemAndSelectNext + , treeCursorDeleteElemAndSelectAbove + , treeCursorRemoveElem + , treeCursorDeleteElem + ) where import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE @@ -27,153 +27,150 @@ import Cursor.Types 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} + case treeAbove of + Nothing -> Just Deleted + Just ta -> + case treeAboveLefts ta of + [] -> Nothing + 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} + case treeAbove of + Nothing -> Just Deleted + Just ta -> + case treeAboveRights ta of + [] -> Nothing + 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 - } + case treeAbove of + Nothing -> Deleted + Just TreeAbove {..} -> + Updated $ + TreeCursor + { treeAbove = treeAboveAbove + , treeCurrent = g treeAboveNode + , treeBelow = openForest $ reverse treeAboveLefts ++ treeAboveRights + } treeCursorRemoveSubTree :: - (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorRemoveSubTree g tc = - joinDeletes - (treeCursorDeleteSubTreeAndSelectPrevious g tc) - (treeCursorDeleteSubTreeAndSelectNext g tc) <|> - treeCursorDeleteSubTreeAndSelectAbove g tc + joinDeletes + (treeCursorDeleteSubTreeAndSelectPrevious g tc) + (treeCursorDeleteSubTreeAndSelectNext g tc) <|> + treeCursorDeleteSubTreeAndSelectAbove g tc treeCursorDeleteSubTree :: - (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorDeleteSubTree g tc = - joinDeletes - (treeCursorDeleteSubTreeAndSelectNext g tc) - (treeCursorDeleteSubTreeAndSelectPrevious g tc) <|> - treeCursorDeleteSubTreeAndSelectAbove g tc + joinDeletes + (treeCursorDeleteSubTreeAndSelectNext 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 -> - case treeBelow of - EmptyCForest -> Just Deleted - _ -> Nothing - Just ta -> - case treeAboveLefts ta of - [] -> Nothing - tree:xs -> - Just . Updated . makeTreeCursorWithAbove g tree $ - Just - ta - { treeAboveLefts = xs - , treeAboveRights = - unpackCForest treeBelow ++ treeAboveRights ta - } + case treeAbove of + Nothing -> + case treeBelow of + EmptyCForest -> Just Deleted + _ -> Nothing + Just ta -> + case treeAboveLefts ta of + [] -> Nothing + tree:xs -> + Just . Updated . makeTreeCursorWithAbove g tree $ + 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 -> - case treeAbove of - Nothing -> Just Deleted - Just ta -> - case treeAboveRights ta of - [] -> Nothing - tree:xs -> - Just . Updated . makeTreeCursorWithAbove g tree $ - Just ta {treeAboveRights = xs} - ClosedForest ts -> - case treeAbove of - Nothing -> - case ts of - (Node e ts_ :| xs) -> - let t = CNode e $ closedForest $ ts_ ++ xs - in Just . Updated $ - makeTreeCursorWithAbove g t treeAbove - Just ta -> - case treeAboveRights ta of - [] -> Nothing - tree:xs -> - Just . Updated . makeTreeCursorWithAbove g tree $ - 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 - in Just . Updated $ makeTreeCursorWithAbove g t treeAbove + case treeBelow of + EmptyCForest -> + case treeAbove of + Nothing -> Just Deleted + Just ta -> + case treeAboveRights ta of + [] -> Nothing + tree:xs -> + Just . Updated . makeTreeCursorWithAbove g tree $ + Just ta {treeAboveRights = xs} + ClosedForest ts -> + case treeAbove of + Nothing -> + case ts of + (Node e ts_ :| xs) -> + let t = CNode e $ closedForest $ ts_ ++ xs + in Just . Updated $ makeTreeCursorWithAbove g t treeAbove + Just ta -> + case treeAboveRights ta of + [] -> Nothing + tree:xs -> + Just . Updated . makeTreeCursorWithAbove g tree $ + 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 + 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 -> - case treeBelow of - EmptyCForest -> Just Deleted - _ -> Nothing - Just TreeAbove {..} -> - Just $ - Updated $ - TreeCursor - { treeAbove = treeAboveAbove - , treeCurrent = g treeAboveNode - , treeBelow = - openForest $ - reverse treeAboveLefts ++ - unpackCForest treeBelow ++ treeAboveRights - } + case treeAbove of + Nothing -> + case treeBelow of + EmptyCForest -> Just Deleted + _ -> Nothing + Just TreeAbove {..} -> + Just $ + Updated $ + TreeCursor + { treeAbove = treeAboveAbove + , treeCurrent = g treeAboveNode + , treeBelow = + openForest $ + reverse treeAboveLefts ++ unpackCForest treeBelow ++ treeAboveRights + } treeCursorRemoveElem :: - (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorRemoveElem g tc = - joinDeletes3 - (treeCursorDeleteElemAndSelectPrevious g tc) - (treeCursorDeleteElemAndSelectNext g tc) - (treeCursorDeleteElemAndSelectAbove g tc) + joinDeletes3 + (treeCursorDeleteElemAndSelectPrevious g tc) + (treeCursorDeleteElemAndSelectNext g tc) + (treeCursorDeleteElemAndSelectAbove g tc) treeCursorDeleteElem :: - (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) treeCursorDeleteElem g tc = - joinDeletes3 - (treeCursorDeleteElemAndSelectNext g tc) - (treeCursorDeleteElemAndSelectPrevious g tc) - (treeCursorDeleteElemAndSelectAbove g tc) + joinDeletes3 + (treeCursorDeleteElemAndSelectNext g tc) + (treeCursorDeleteElemAndSelectPrevious g tc) + (treeCursorDeleteElemAndSelectAbove 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 @@ -4,12 +4,12 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Demote - ( treeCursorDemoteElem - , treeCursorDemoteSubTree - , DemoteResult(..) - , treeCursorDemoteElemUnder - , treeCursorDemoteSubTreeUnder - ) where + ( treeCursorDemoteElem + , treeCursorDemoteSubTree + , DemoteResult(..) + , treeCursorDemoteElemUnder + , treeCursorDemoteSubTreeUnder + ) where import Data.Validity @@ -40,25 +40,23 @@ -- > | |- d -- > |- e treeCursorDemoteElem :: - (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b) treeCursorDemoteElem f g tc = - case treeAbove tc of - Nothing -> CannotDemoteTopNode - Just ta -> - case treeAboveLefts ta of - [] -> NoSiblingsToDemoteUnder - (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 - } + case treeAbove tc of + Nothing -> CannotDemoteTopNode + Just ta -> + case treeAboveLefts ta of + [] -> NoSiblingsToDemoteUnder + (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 + } -- | Demotes the current subtree to the level of its children. -- @@ -82,29 +80,29 @@ -- > | |- d -- > |- e treeCursorDemoteSubTree :: - (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b) treeCursorDemoteSubTree f g tc = - case treeAbove tc of - Nothing -> CannotDemoteTopNode - Just ta -> - case treeAboveLefts ta of - [] -> NoSiblingsToDemoteUnder - (CNode t ls:ts) -> - Demoted $ - makeTreeCursorWithAbove g (currentTree f tc) $ - Just - TreeAbove - { treeAboveLefts = reverse $ unpackCForest ls - , treeAboveAbove = Just ta {treeAboveLefts = ts} - , treeAboveNode = t - , treeAboveRights = [] - } + case treeAbove tc of + Nothing -> CannotDemoteTopNode + Just ta -> + case treeAboveLefts ta of + [] -> NoSiblingsToDemoteUnder + (CNode t ls:ts) -> + Demoted $ + makeTreeCursorWithAbove g (currentTree f tc) $ + Just + TreeAbove + { treeAboveLefts = reverse $ unpackCForest ls + , treeAboveAbove = Just ta {treeAboveLefts = ts} + , treeAboveNode = t + , treeAboveRights = [] + } data DemoteResult a - = CannotDemoteTopNode - | NoSiblingsToDemoteUnder - | Demoted a - deriving (Show, Eq, Generic, Functor) + = CannotDemoteTopNode + | NoSiblingsToDemoteUnder + | Demoted a + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (DemoteResult a) @@ -128,21 +126,20 @@ -- > | |- b treeCursorDemoteElemUnder :: b -> b -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorDemoteElemUnder b1 b2 tc = do - ta <- treeAbove tc - let ta' = - ta {treeAboveRights = CNode b2 (treeBelow tc) : treeAboveRights ta} - pure - tc - { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = Just ta' - , treeAboveNode = b1 - , treeAboveRights = [] - } - , treeBelow = emptyCForest - } + ta <- treeAbove tc + let ta' = ta {treeAboveRights = CNode b2 (treeBelow tc) : treeAboveRights ta} + pure + tc + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [] + , treeAboveAbove = Just ta' + , treeAboveNode = b1 + , treeAboveRights = [] + } + , treeBelow = emptyCForest + } -- | Demotes the current subtree to the level of its children, by adding a root. -- @@ -160,13 +157,13 @@ -- > |- b treeCursorDemoteSubTreeUnder :: b -> TreeCursor a b -> TreeCursor a b treeCursorDemoteSubTreeUnder b tc = - tc + tc { treeAbove = - Just - TreeAbove - { treeAboveLefts = [] - , treeAboveAbove = treeAbove tc - , treeAboveNode = b - , treeAboveRights = [] - } + Just + TreeAbove + { 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 @@ -4,13 +4,13 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Draw - ( drawTreeCursor - , treeCursorWithPointer - , showCForest - , showCTree - , showForest - , showTree - ) where + ( drawTreeCursor + , treeCursorWithPointer + , showCForest + , showCTree + , showForest + , showTree + ) where import qualified Data.List.NonEmpty as NE import Data.Tree @@ -22,24 +22,24 @@ treeCursorWithPointer :: (Show a, Show b) => TreeCursor a b -> Tree String treeCursorWithPointer TreeCursor {..} = - wrapAbove treeAbove $ - Node (show treeCurrent ++ " <---") $ showCForest treeBelow + wrapAbove treeAbove $ + Node (show treeCurrent ++ " <---") $ showCForest treeBelow where wrapAbove :: (Show b) => Maybe (TreeAbove b) -> Tree String -> Tree String wrapAbove Nothing t = t wrapAbove (Just TreeAbove {..}) t = - wrapAbove treeAboveAbove $ - Node (show treeAboveNode) $ - concat - [ map showCTree $ reverse treeAboveLefts - , [t] - , map showCTree treeAboveRights - ] + wrapAbove treeAboveAbove $ + Node (show treeAboveNode) $ + concat + [ map showCTree $ reverse treeAboveLefts + , [t] + , map showCTree treeAboveRights + ] showCForest :: Show a => CForest a -> Forest String showCForest EmptyCForest = [] showCForest (ClosedForest ts) = - map (fmap ("hidden: " ++)) $ map showTree $ NE.toList ts + map (fmap ("hidden: " ++)) $ map showTree $ NE.toList ts showCForest (OpenForest ts) = map showCTree $ NE.toList ts showCTree :: Show a => CTree a -> Tree String 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 @@ -4,14 +4,14 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Insert - ( treeCursorInsert - , treeCursorInsertAndSelect - , treeCursorAppend - , treeCursorAppendAndSelect - , treeCursorAddChildAtPos - , treeCursorAddChildAtStart - , treeCursorAddChildAtEnd - ) where + ( treeCursorInsert + , treeCursorInsertAndSelect + , treeCursorAppend + , treeCursorAppendAndSelect + , treeCursorAddChildAtPos + , treeCursorAddChildAtStart + , treeCursorAddChildAtEnd + ) where import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ((<|)) @@ -22,67 +22,54 @@ treeCursorInsert :: Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorInsert tree tc@TreeCursor {..} = do - ta <- treeAbove - let newTreeAbove = ta {treeAboveLefts = makeCTree tree : treeAboveLefts ta} - pure tc {treeAbove = Just newTreeAbove} + ta <- treeAbove + let newTreeAbove = ta {treeAboveLefts = makeCTree tree : treeAboveLefts ta} + pure tc {treeAbove = Just newTreeAbove} treeCursorInsertAndSelect :: - (a -> b) - -> (b -> a) - -> Tree b - -> TreeCursor a b - -> Maybe (TreeCursor a b) + (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 + ta <- treeAbove + let newTreeAbove = + ta {treeAboveRights = currentTree f tc : treeAboveRights ta} + pure $ makeTreeCursorWithAbove g (makeCTree tree) $ Just newTreeAbove treeCursorAppend :: Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorAppend tree tc@TreeCursor {..} = do - ta <- treeAbove - let newTreeAbove = - ta {treeAboveRights = makeCTree tree : treeAboveRights ta} - pure tc {treeAbove = Just newTreeAbove} + ta <- treeAbove + let newTreeAbove = ta {treeAboveRights = makeCTree tree : treeAboveRights ta} + pure tc {treeAbove = Just newTreeAbove} treeCursorAppendAndSelect :: - (a -> b) - -> (b -> a) - -> Tree b - -> TreeCursor a b - -> Maybe (TreeCursor a b) + (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 + ta <- treeAbove + let newTreeAbove = ta {treeAboveLefts = currentTree f tc : treeAboveLefts ta} + pure $ makeTreeCursorWithAbove g (makeCTree tree) $ Just newTreeAbove -- 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 = - case treeBelow tc of - EmptyCForest -> tc {treeBelow = openForest [makeCTree t]} - ClosedForest ts -> - let (before, after) = splitAt i $ NE.toList ts - in tc - {treeBelow = openForest $ map makeCTree $ before ++ [t] ++ after} - OpenForest ts -> - let (before, after) = splitAt i $ NE.toList ts - in tc {treeBelow = openForest $ before ++ [makeCTree t] ++ after} + case treeBelow tc of + EmptyCForest -> tc {treeBelow = openForest [makeCTree t]} + ClosedForest ts -> + let (before, after) = splitAt i $ NE.toList ts + in tc {treeBelow = openForest $ map makeCTree $ before ++ [t] ++ after} + OpenForest ts -> + let (before, after) = splitAt i $ NE.toList ts + in tc {treeBelow = openForest $ before ++ [makeCTree t] ++ after} treeCursorAddChildAtStart :: Tree b -> TreeCursor a b -> TreeCursor a b treeCursorAddChildAtStart t tc = - case treeBelow tc of - EmptyCForest -> tc {treeBelow = openForest [makeCTree t]} - ClosedForest ts -> - tc {treeBelow = OpenForest $ NE.map makeCTree $ t <| ts} - OpenForest ts -> tc {treeBelow = OpenForest $ makeCTree t <| ts} + case treeBelow tc of + EmptyCForest -> tc {treeBelow = openForest [makeCTree t]} + ClosedForest ts -> tc {treeBelow = OpenForest $ NE.map makeCTree $ t <| ts} + OpenForest ts -> tc {treeBelow = OpenForest $ makeCTree t <| ts} treeCursorAddChildAtEnd :: Tree b -> TreeCursor a b -> TreeCursor a b treeCursorAddChildAtEnd t tc = - case treeBelow tc of - 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]} + case treeBelow tc of + 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]} 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 @@ -4,24 +4,24 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Movement - ( treeCursorSelection - , TreeCursorSelection(..) - , treeCursorSelect - , treeCursorSelectPrev - , treeCursorSelectNext - , treeCursorSelectFirst - , treeCursorSelectLast - , treeCursorSelectAbove - , treeCursorSelectBelowAtPos - , treeCursorSelectBelowAtStart - , treeCursorSelectBelowAtEnd - , treeCursorSelectBelowAtStartRecursively - , treeCursorSelectBelowAtEndRecursively - , treeCursorSelectPrevOnSameLevel - , treeCursorSelectNextOnSameLevel - , treeCursorSelectAbovePrev - , treeCursorSelectAboveNext - ) where + ( 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 () @@ -38,150 +38,148 @@ wrap :: Maybe (TreeAbove a) -> TreeCursorSelection -> TreeCursorSelection wrap Nothing ts = ts wrap (Just ta) ts = - wrap (treeAboveAbove ta) $ SelectChild (length $ treeAboveLefts 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 + makeTreeCursorWithSelection f g sel . rebuildTreeCursor f treeCursorSelectPrev :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (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) + (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 + (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b treeCursorSelectFirst f g tc = - maybe tc (treeCursorSelectFirst f g) $ treeCursorSelectPrev f g tc + maybe tc (treeCursorSelectFirst f g) $ treeCursorSelectPrev f g tc treeCursorSelectLast :: (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b treeCursorSelectLast f g tc = - maybe tc (treeCursorSelectLast f g) $ treeCursorSelectNext f g tc + maybe tc (treeCursorSelectLast f g) $ treeCursorSelectNext f g tc treeCursorSelectAbove :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectAbove f g tc@TreeCursor {..} = - case treeAbove of - Nothing -> Nothing - Just TreeAbove {..} -> - let newForest = - (reverse treeAboveLefts) ++ - [currentTree f tc] ++ treeAboveRights - newTree = CNode treeAboveNode $ openForest newForest - in Just $ makeTreeCursorWithAbove g newTree treeAboveAbove + case treeAbove of + Nothing -> Nothing + Just TreeAbove {..} -> + let newForest = + (reverse treeAboveLefts) ++ [currentTree f tc] ++ treeAboveRights + newTree = CNode treeAboveNode $ openForest newForest + 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 - ClosedForest _ -> Nothing - OpenForest ts -> - case splitAt pos $ NE.toList ts of - (_, []) -> Nothing - (lefts, current:rights) -> - Just $ - makeTreeCursorWithAbove g current $ - Just $ - TreeAbove - { treeAboveLefts = reverse lefts - , treeAboveAbove = treeAbove - , treeAboveNode = f treeCurrent - , treeAboveRights = rights - } + case treeBelow of + EmptyCForest -> Nothing + ClosedForest _ -> Nothing + OpenForest ts -> + case splitAt pos $ NE.toList ts of + (_, []) -> Nothing + (lefts, current:rights) -> + Just $ + 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) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtStart f g = treeCursorSelectBelowAtPos f g 0 treeCursorSelectBelowAtEnd :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectBelowAtEnd f g tc = - case treeBelow tc of - EmptyCForest -> Nothing - ClosedForest _ -> Nothing - OpenForest ts -> treeCursorSelectBelowAtPos f g (length ts - 1) tc + case treeBelow tc of + EmptyCForest -> Nothing + ClosedForest _ -> Nothing + 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 + 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 + go <$> treeCursorSelectBelowAtEnd f g tc where go c = maybe c go $ treeCursorSelectBelowAtEnd f g c treeCursorSelectPrevOnSameLevel :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectPrevOnSameLevel f g tc@TreeCursor {..} = do - ta <- treeAbove - case treeAboveLefts ta of - [] -> Nothing - tree:xs -> - Just . makeTreeCursorWithAbove g tree $ - Just - ta - { treeAboveLefts = xs - , treeAboveRights = currentTree f tc : treeAboveRights ta - } + ta <- treeAbove + case treeAboveLefts ta of + [] -> Nothing + tree:xs -> + Just . makeTreeCursorWithAbove g tree $ + Just + ta + { treeAboveLefts = xs + , treeAboveRights = currentTree f tc : treeAboveRights ta + } treeCursorSelectNextOnSameLevel :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (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 -> - Just . makeTreeCursorWithAbove g tree . Just $ - ta - { treeAboveLefts = currentTree f tc : treeAboveLefts ta - , treeAboveRights = xs - } + ta <- treeAbove + case treeAboveRights ta of + [] -> Nothing + tree:xs -> + Just . makeTreeCursorWithAbove g tree . Just $ + ta + { treeAboveLefts = currentTree f tc : treeAboveLefts ta + , treeAboveRights = xs + } -- | 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) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectAbovePrev f g = - treeCursorSelectPrevOnSameLevel f g >=> - treeCursorSelectBelowAtEndRecursively f g + treeCursorSelectPrevOnSameLevel f g >=> + treeCursorSelectBelowAtEndRecursively f g -- | Go up as far as necessary to find a next element on a level above and forward -- -- Note: This will fail if there is a next node on the same level or any node below the current node treeCursorSelectAboveNext :: - (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) treeCursorSelectAboveNext f g tc = - case treeCursorSelectNextOnSameLevel f g tc of - Just _ -> Nothing - Nothing -> - case treeBelow tc of - EmptyCForest -> go tc - ClosedForest _ -> go tc - OpenForest ts -> - if null ts - then go tc - else Nothing + case treeCursorSelectNextOnSameLevel f g tc of + Just _ -> Nothing + Nothing -> + case treeBelow tc of + EmptyCForest -> go tc + ClosedForest _ -> go tc + OpenForest ts -> + if null ts + then go tc + else Nothing where go tc_ = do - tc' <- treeCursorSelectAbove f g tc_ - case treeCursorSelectNextOnSameLevel f g tc' of - Nothing -> go tc' - Just tc'' -> pure tc'' + tc' <- treeCursorSelectAbove f g tc_ + case treeCursorSelectNextOnSameLevel f g tc' of + Nothing -> go tc' + Just tc'' -> pure 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 @@ -4,11 +4,11 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Promote - ( treeCursorPromoteElem - , PromoteElemResult(..) - , treeCursorPromoteSubTree - , PromoteResult(..) - ) where + ( treeCursorPromoteElem + , PromoteElemResult(..) + , treeCursorPromoteSubTree + , PromoteResult(..) + ) where import Data.Validity @@ -45,69 +45,68 @@ -- > |- 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 <- - case treeAbove tc of - Nothing -> CannotPromoteTopElem - Just ta -> pure ta + ta <- + case treeAbove tc of + Nothing -> CannotPromoteTopElem + Just ta -> pure ta -- 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) -> - pure $ - CNode - t - (openForest $ - unpackCForest ls ++ unpackCForest (treeBelow tc)) : - ts - taa <- - case treeAboveAbove ta of - Nothing -> NoGrandparentToPromoteElemUnder - Just taa -> pure taa - pure $ - makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $ - Just $ - taa - { treeAboveLefts = - CNode - (treeAboveNode ta) - (openForest $ reverse lefts ++ treeAboveRights ta) : - treeAboveLefts taa - } + lefts <- + case (treeBelow tc) of + EmptyCForest -> pure $ treeAboveLefts ta + _ -> + case treeAboveLefts ta of + [] -> NoSiblingsToAdoptChildren + (CNode t ls:ts) -> + pure $ + CNode + t + (openForest $ unpackCForest ls ++ unpackCForest (treeBelow tc)) : + ts + taa <- + case treeAboveAbove ta of + Nothing -> NoGrandparentToPromoteElemUnder + Just taa -> pure taa + pure $ + makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $ + Just $ + taa + { treeAboveLefts = + CNode + (treeAboveNode ta) + (openForest $ reverse lefts ++ treeAboveRights ta) : + treeAboveLefts taa + } data PromoteElemResult a - = CannotPromoteTopElem - | NoGrandparentToPromoteElemUnder - | NoSiblingsToAdoptChildren - | PromotedElem a - deriving (Show, Eq, Generic, Functor) + = CannotPromoteTopElem + | NoGrandparentToPromoteElemUnder + | NoSiblingsToAdoptChildren + | PromotedElem a + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (PromoteElemResult a) instance Applicative PromoteElemResult where - pure = PromotedElem - CannotPromoteTopElem <*> _ = CannotPromoteTopElem - NoGrandparentToPromoteElemUnder <*> _ = NoGrandparentToPromoteElemUnder - NoSiblingsToAdoptChildren <*> _ = NoSiblingsToAdoptChildren - PromotedElem f <*> PromotedElem a = PromotedElem $ f a - PromotedElem _ <*> CannotPromoteTopElem = CannotPromoteTopElem - PromotedElem _ <*> NoSiblingsToAdoptChildren = NoSiblingsToAdoptChildren - PromotedElem _ <*> NoGrandparentToPromoteElemUnder = - NoGrandparentToPromoteElemUnder + pure = PromotedElem + CannotPromoteTopElem <*> _ = CannotPromoteTopElem + NoGrandparentToPromoteElemUnder <*> _ = NoGrandparentToPromoteElemUnder + NoSiblingsToAdoptChildren <*> _ = NoSiblingsToAdoptChildren + PromotedElem f <*> PromotedElem a = PromotedElem $ f a + PromotedElem _ <*> CannotPromoteTopElem = CannotPromoteTopElem + PromotedElem _ <*> NoSiblingsToAdoptChildren = NoSiblingsToAdoptChildren + PromotedElem _ <*> NoGrandparentToPromoteElemUnder = + NoGrandparentToPromoteElemUnder instance Monad PromoteElemResult where - CannotPromoteTopElem >>= _ = CannotPromoteTopElem - NoGrandparentToPromoteElemUnder >>= _ = NoGrandparentToPromoteElemUnder - NoSiblingsToAdoptChildren >>= _ = NoSiblingsToAdoptChildren - PromotedElem a >>= f = f a + CannotPromoteTopElem >>= _ = CannotPromoteTopElem + NoGrandparentToPromoteElemUnder >>= _ = NoGrandparentToPromoteElemUnder + NoSiblingsToAdoptChildren >>= _ = NoSiblingsToAdoptChildren + PromotedElem a >>= f = f a -- | Promotes the current node to the level of its parent. -- @@ -137,45 +136,44 @@ -- > | |- e -- > |- h treeCursorPromoteSubTree :: - (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteResult (TreeCursor a b) + (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteResult (TreeCursor a b) treeCursorPromoteSubTree f g tc = do - ta <- - case treeAbove tc of - Nothing -> CannotPromoteTopNode - Just ta -> pure ta - taa <- - case treeAboveAbove ta of - Nothing -> NoGrandparentToPromoteUnder - Just taa -> pure taa - pure $ - makeTreeCursorWithAbove g (currentTree f tc) $ - Just $ - taa - { treeAboveLefts = - CNode - (treeAboveNode ta) - (openForest $ - reverse (treeAboveLefts ta) ++ treeAboveRights ta) : - treeAboveLefts taa - } + ta <- + case treeAbove tc of + Nothing -> CannotPromoteTopNode + Just ta -> pure ta + taa <- + case treeAboveAbove ta of + Nothing -> NoGrandparentToPromoteUnder + Just taa -> pure taa + pure $ + makeTreeCursorWithAbove g (currentTree f tc) $ + Just $ + taa + { treeAboveLefts = + CNode + (treeAboveNode ta) + (openForest $ reverse (treeAboveLefts ta) ++ treeAboveRights ta) : + treeAboveLefts taa + } data PromoteResult a - = CannotPromoteTopNode - | NoGrandparentToPromoteUnder - | Promoted a - deriving (Show, Eq, Generic, Functor) + = CannotPromoteTopNode + | NoGrandparentToPromoteUnder + | Promoted a + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (PromoteResult a) instance Applicative PromoteResult where - pure = Promoted - CannotPromoteTopNode <*> _ = CannotPromoteTopNode - NoGrandparentToPromoteUnder <*> _ = NoGrandparentToPromoteUnder - Promoted f <*> Promoted a = Promoted $ f a - Promoted _ <*> CannotPromoteTopNode = CannotPromoteTopNode - Promoted _ <*> NoGrandparentToPromoteUnder = NoGrandparentToPromoteUnder + pure = Promoted + CannotPromoteTopNode <*> _ = CannotPromoteTopNode + NoGrandparentToPromoteUnder <*> _ = NoGrandparentToPromoteUnder + Promoted f <*> Promoted a = Promoted $ f a + Promoted _ <*> CannotPromoteTopNode = CannotPromoteTopNode + Promoted _ <*> NoGrandparentToPromoteUnder = NoGrandparentToPromoteUnder instance Monad PromoteResult where - CannotPromoteTopNode >>= _ = CannotPromoteTopNode - NoGrandparentToPromoteUnder >>= _ = NoGrandparentToPromoteUnder - Promoted a >>= f = f a + CannotPromoteTopNode >>= _ = CannotPromoteTopNode + NoGrandparentToPromoteUnder >>= _ = NoGrandparentToPromoteUnder + Promoted a >>= f = f a 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 @@ -4,10 +4,10 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Swap - ( treeCursorSwapPrev - , treeCursorSwapNext - , SwapResult(..) - ) where + ( treeCursorSwapPrev + , treeCursorSwapNext + , SwapResult(..) + ) where import Data.Validity @@ -32,21 +32,21 @@ -- > |- a treeCursorSwapPrev :: TreeCursor a b -> SwapResult (TreeCursor a b) treeCursorSwapPrev tc = do - case treeAbove tc of - Nothing -> SwapperIsTopNode - Just ta -> - case treeAboveLefts ta of - [] -> NoSiblingsToSwapWith - (t:ts) -> - Swapped $ - tc - { treeAbove = - Just - ta - { treeAboveLefts = ts - , treeAboveRights = t : treeAboveRights ta - } + case treeAbove tc of + Nothing -> SwapperIsTopNode + Just ta -> + case treeAboveLefts ta of + [] -> NoSiblingsToSwapWith + (t:ts) -> + Swapped $ + tc + { treeAbove = + Just + ta + { treeAboveLefts = ts + , treeAboveRights = t : treeAboveRights ta } + } -- | Swaps the current node with the next node on the same level -- @@ -65,26 +65,26 @@ -- > |- a <-- treeCursorSwapNext :: TreeCursor a b -> SwapResult (TreeCursor a b) treeCursorSwapNext tc = - case treeAbove tc of - Nothing -> SwapperIsTopNode - Just ta -> - case treeAboveRights ta of - [] -> NoSiblingsToSwapWith - (t:ts) -> - Swapped $ - tc - { treeAbove = - Just - ta - { treeAboveLefts = t : treeAboveLefts ta - , treeAboveRights = ts - } + case treeAbove tc of + Nothing -> SwapperIsTopNode + Just ta -> + case treeAboveRights ta of + [] -> NoSiblingsToSwapWith + (t:ts) -> + Swapped $ + tc + { treeAbove = + Just + ta + { treeAboveLefts = t : treeAboveLefts ta + , treeAboveRights = ts } + } data SwapResult a - = SwapperIsTopNode - | NoSiblingsToSwapWith - | Swapped a - deriving (Show, Eq, Generic, Functor) + = SwapperIsTopNode + | NoSiblingsToSwapWith + | Swapped a + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (SwapResult a) 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 @@ -4,32 +4,32 @@ {-# LANGUAGE DeriveFunctor #-} module Cursor.Tree.Types - ( TreeCursor(..) - , treeCursorAboveL - , treeCursorCurrentL - , treeCursorBelowL - , treeCursorCurrentSubTreeL - , TreeAbove(..) - , treeAboveLeftsL - , treeAboveAboveL - , treeAboveNodeL - , treeAboveRightsL - , TreeCursorSelection(..) + ( 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 + , CTree(..) + , makeCTree + , cTree + , rebuildCTree + , CForest(..) + , makeCForest + , cForest + , rebuildCForest + , emptyCForest + , openForest + , closedForest + , lengthCForest + , unpackCForest + ) where import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE @@ -41,11 +41,13 @@ import Lens.Micro -data TreeCursor a b = TreeCursor +data TreeCursor a b = + TreeCursor { treeAbove :: !(Maybe (TreeAbove b)) , treeCurrent :: !a - , treeBelow :: !(CForest b) - } deriving (Show, Eq, Generic) + , treeBelow :: (CForest b) + } + deriving (Show, Eq, Generic) treeCursorAboveL :: Lens' (TreeCursor a b) (Maybe (TreeAbove b)) treeCursorAboveL = lens treeAbove $ \tc ta -> tc {treeAbove = ta} @@ -58,18 +60,20 @@ treeCursorCurrentSubTreeL :: Lens' (TreeCursor a b) (a, CForest b) treeCursorCurrentSubTreeL = - lens + lens (\tc -> (treeCurrent tc, treeBelow tc)) (\tc (a, cf) -> tc {treeCurrent = a, treeBelow = cf}) instance (Validity a, Validity b) => Validity (TreeCursor a b) -data TreeAbove b = TreeAbove +data TreeAbove b = + TreeAbove { treeAboveLefts :: ![CTree b] -- In reverse order , treeAboveAbove :: !(Maybe (TreeAbove b)) , treeAboveNode :: !b , treeAboveRights :: ![CTree b] - } deriving (Show, Eq, Generic, Functor) + } + deriving (Show, Eq, Generic, Functor) instance Validity b => Validity (TreeAbove b) @@ -86,17 +90,15 @@ treeAboveRightsL = lens treeAboveRights $ \ta tar -> ta {treeAboveRights = tar} data TreeCursorSelection - = SelectNode - | SelectChild !Int - !TreeCursorSelection - deriving (Show, Eq, Generic) + = SelectNode + | SelectChild !Int !TreeCursorSelection + deriving (Show, Eq, Generic) instance Validity TreeCursorSelection data CTree a = - CNode !a - !(CForest a) - deriving (Show, Eq, Generic, Functor) + CNode !a (CForest a) + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (CTree a) @@ -110,10 +112,10 @@ rebuildCTree (CNode v cf) = Node v $ rebuildCForest cf data CForest a - = EmptyCForest - | ClosedForest !(NonEmpty (Tree a)) - | OpenForest !(NonEmpty (CTree a)) - deriving (Show, Eq, Generic, Functor) + = EmptyCForest + | ClosedForest !(NonEmpty (Tree a)) + | OpenForest !(NonEmpty (CTree a)) + deriving (Show, Eq, Generic, Functor) instance Validity a => Validity (CForest a) @@ -122,9 +124,9 @@ cForest :: Bool -> Forest a -> CForest a cForest b f = - if b - then openForest $ map (cTree b) f - else closedForest f + if b + then openForest $ map (cTree b) f + else closedForest f rebuildCForest :: CForest a -> Forest a rebuildCForest EmptyCForest = [] @@ -136,15 +138,15 @@ openForest :: [CTree a] -> CForest a openForest ts = - case NE.nonEmpty ts of - Nothing -> emptyCForest - Just ne -> OpenForest ne + case NE.nonEmpty ts of + Nothing -> emptyCForest + Just ne -> OpenForest ne closedForest :: [Tree a] -> CForest a closedForest ts = - case NE.nonEmpty ts of - Nothing -> emptyCForest - Just ne -> ClosedForest ne + case NE.nonEmpty ts of + Nothing -> emptyCForest + Just ne -> ClosedForest ne lengthCForest :: CForest a -> Int lengthCForest EmptyCForest = 0 diff --git a/src/Cursor/Types.hs b/src/Cursor/Types.hs --- a/src/Cursor/Types.hs +++ b/src/Cursor/Types.hs @@ -14,56 +14,64 @@ import Lens.Micro data DeleteOrUpdate a - = Deleted - | Updated a - deriving (Show, Eq, Generic) + = Deleted + | Updated a + deriving (Show, Eq, Generic) instance Validity a => Validity (DeleteOrUpdate a) instance Functor DeleteOrUpdate where - fmap _ Deleted = Deleted - fmap f (Updated a) = Updated (f a) + fmap _ Deleted = Deleted + fmap f (Updated a) = Updated (f a) instance Applicative DeleteOrUpdate where - pure = Updated - Deleted <*> _ = Deleted - _ <*> Deleted = Deleted - (Updated f) <*> (Updated a) = Updated (f a) + pure = Updated + Deleted <*> _ = Deleted + _ <*> Deleted = Deleted + (Updated f) <*> (Updated a) = Updated (f a) instance Alternative DeleteOrUpdate where - empty = Deleted - Updated a <|> _ = Updated a - Deleted <|> doua = doua + empty = Deleted + Updated a <|> _ = Updated a + Deleted <|> doua = doua joinDeletes :: - Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> DeleteOrUpdate a + Maybe (DeleteOrUpdate a) -> Maybe (DeleteOrUpdate a) -> DeleteOrUpdate a joinDeletes m1 m2 = - case (m1, m2) of - (Nothing, Nothing) -> Deleted - (Nothing, Just a) -> a - (Just a, _) -> a + case (m1, m2) of + (Nothing, Nothing) -> Deleted + (Nothing, Just a) -> a + (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 - (Nothing, Nothing, Just a) -> a - (Nothing, Just a, _) -> a - (Just a, _, _) -> a + case (m1, m2, m3) of + (Nothing, Nothing, Nothing) -> Deleted + (Nothing, Nothing, Just a) -> a + (Nothing, Just a, _) -> a + (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 +dullMDelete Nothing = Nothing +dullMDelete (Just dou) = dullDelete dou + +dullDelete :: DeleteOrUpdate a -> Maybe a +dullDelete Deleted = Nothing +dullDelete (Updated a) = Just a