diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cursor.cabal b/cursor.cabal new file mode 100644 --- /dev/null +++ b/cursor.cabal @@ -0,0 +1,60 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 02faf660887f273e997cf0722b08edb14f51ed1f1ef1a064ee50ae52994ee175 + +name: cursor +version: 0.0.0.0 +synopsis: Purely Functional Cursors +description: Purely Functional Cursors for common data structures +category: Editor +homepage: https://github.com/NorfairKing/cursor +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright: (c) 2018 Tom Sydney Kerckhove +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: + Cursor.Forest + Cursor.List + Cursor.List.NonEmpty + Cursor.Map + Cursor.Map.KeyValue + Cursor.Simple.Forest + Cursor.Simple.List.NonEmpty + Cursor.Simple.Map + Cursor.Simple.Map.KeyValue + Cursor.Simple.Tree + Cursor.Text + Cursor.TextField + Cursor.Tree + Cursor.Tree.Base + Cursor.Tree.Collapse + Cursor.Tree.Delete + Cursor.Tree.Demote + Cursor.Tree.Draw + Cursor.Tree.Insert + Cursor.Tree.Movement + Cursor.Tree.Promote + Cursor.Tree.Swap + Cursor.Tree.Types + Cursor.Types + other-modules: + Paths_cursor + hs-source-dirs: + src/ + ghc-options: -Wall + build-depends: + base <5 + , containers + , microlens + , text + , validity + , validity-containers + , validity-text + default-language: Haskell2010 diff --git a/src/Cursor/Forest.hs b/src/Cursor/Forest.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Forest.hs @@ -0,0 +1,743 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 + +import GHC.Generics (Generic) + +import Data.Validity +import Data.Validity.Tree () + +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe +import Data.Tree + +import Control.Applicative + +import Lens.Micro + +import Cursor.List.NonEmpty +import Cursor.Tree +import Cursor.Types + +newtype ForestCursor a b = ForestCursor + { forestCursorListCursor :: NonEmptyCursor (TreeCursor a b) (CTree b) + } deriving (Show, Eq, Generic) + +instance (Validity a, Validity b) => Validity (ForestCursor a b) + +makeForestCursor :: (b -> a) -> NonEmpty (CTree b) -> ForestCursor a b +makeForestCursor g = ForestCursor . makeNonEmptyCursor (makeTreeCursor g) + +rebuildForestCursor :: (a -> b) -> ForestCursor a b -> NonEmpty (CTree b) +rebuildForestCursor f = + 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) + +mapForestCursor :: (a -> c) -> (b -> d) -> ForestCursor a b -> ForestCursor c d +mapForestCursor f g = + forestCursorListCursorL %~ mapNonEmptyCursor (mapTreeCursor f g) (fmap g) + +forestCursorListCursorL :: + Lens (ForestCursor a b) (ForestCursor c d) (NonEmptyCursor (TreeCursor a b) (CTree b)) (NonEmptyCursor (TreeCursor c d) (CTree d)) +forestCursorListCursorL = + lens forestCursorListCursor $ \fc lc -> fc {forestCursorListCursor = lc} + +forestCursorSelectedTreeL :: Lens' (ForestCursor a b) (TreeCursor a b) +forestCursorSelectedTreeL = forestCursorListCursorL . nonEmptyCursorElemL + +forestCursorSelectPrevTreeCursor :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectPrevTreeCursor f g = + forestCursorListCursorL $ + nonEmptyCursorSelectPrev (rebuildTreeCursor f) (makeTreeCursor g) + +forestCursorSelectNextTreeCursor :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectNextTreeCursor f g = + forestCursorListCursorL $ + nonEmptyCursorSelectNext (rebuildTreeCursor f) (makeTreeCursor g) + +forestCursorSelectFirstTreeCursor :: + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectFirstTreeCursor f g = + forestCursorListCursorL %~ + (nonEmptyCursorSelectFirst (rebuildTreeCursor f) (makeTreeCursor g)) + +forestCursorSelectLastTreeCursor :: + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectLastTreeCursor f g = + forestCursorListCursorL %~ + (nonEmptyCursorSelectLast (rebuildTreeCursor f) (makeTreeCursor g)) + +forestCursorSelectNext :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectNext f g fc = + (fc & forestCursorSelectedTreeL (treeCursorSelectNext f g)) <|> + forestCursorSelectNextTreeCursor f g fc + +forestCursorSelectPrev :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectPrev f g fc = + (fc & forestCursorSelectedTreeL (treeCursorSelectPrev f g)) <|> + (forestCursorSelectPrevTreeCursor f g fc >>= + forestCursorSelectedTreeL (treeCursorSelectBelowAtEndRecursively f g)) <|> + (forestCursorSelectPrevTreeCursor f g fc) + +forestCursorSelectNextOnSameLevel :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectNextOnSameLevel f g fc = + (fc & forestCursorSelectedTreeL (treeCursorSelectNextOnSameLevel f g)) <|> + forestCursorSelectNextTreeCursor f g fc + +forestCursorSelectPrevOnSameLevel :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectPrevOnSameLevel f g fc = + (fc & forestCursorSelectedTreeL (treeCursorSelectPrevOnSameLevel f g)) <|> + forestCursorSelectPrevTreeCursor f g fc + +forestCursorSelectFirst :: + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectFirst f g fc = + 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 -> fc + +forestCursorSelectLast :: + (a -> b) -> (b -> a) -> ForestCursor a b -> ForestCursor a b +forestCursorSelectLast f g fc = + 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 -> fc + +forestCursorSelectBelowAtPos :: + (a -> b) + -> (b -> a) + -> Int + -> ForestCursor a b + -> Maybe (ForestCursor a b) +forestCursorSelectBelowAtPos f g i = + forestCursorSelectedTreeL $ treeCursorSelectBelowAtPos f g i + +forestCursorSelectBelowAtStart :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectBelowAtStart f g = + forestCursorSelectedTreeL $ treeCursorSelectBelowAtStart f g + +forestCursorSelectBelowAtEnd :: + (a -> b) -> (b -> a) -> ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorSelectBelowAtEnd f g = + forestCursorSelectedTreeL $ treeCursorSelectBelowAtEnd f g + +forestCursorSelection :: ForestCursor a b -> Int +forestCursorSelection fc = + nonEmptyCursorSelection $ fc ^. forestCursorListCursorL + +forestCursorSelectIndex :: + (a -> b) + -> (b -> a) + -> Int + -> ForestCursor a b + -> Maybe (ForestCursor a b) +forestCursorSelectIndex f g i = + forestCursorListCursorL + (nonEmptyCursorSelectIndex (rebuildTreeCursor f) (makeTreeCursor g) i) + +forestCursorOpenCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorOpenCurrentForest = + forestCursorSelectedTreeL treeCursorOpenCurrentForest + +forestCursorCloseCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorCloseCurrentForest = + forestCursorSelectedTreeL treeCursorCloseCurrentForest + +forestCursorToggleCurrentForest :: ForestCursor a b -> Maybe (ForestCursor a b) +forestCursorToggleCurrentForest = + forestCursorSelectedTreeL treeCursorToggleCurrentForest + +forestCursorInsertEntireTree :: Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertEntireTree t = + forestCursorListCursorL %~ nonEmptyCursorInsert (makeCTree t) + +forestCursorInsertAndSelectTreeCursor :: + (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertAndSelectTreeCursor f tc = + forestCursorListCursorL %~ + nonEmptyCursorInsertAndSelect (rebuildTreeCursor f) tc + +forestCursorAppendEntireTree :: Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendEntireTree t = + forestCursorListCursorL %~ nonEmptyCursorAppend (makeCTree t) + +forestCursorAppendAndSelectTreeCursor :: + (a -> b) -> TreeCursor a b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendAndSelectTreeCursor f tc = + forestCursorListCursorL %~ + nonEmptyCursorAppendAndSelect (rebuildTreeCursor f) tc + +forestCursorInsertTree :: Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertTree t fc = + fromMaybe (forestCursorInsertEntireTree t fc) $ + fc & forestCursorSelectedTreeL (treeCursorInsert t) + +forestCursorInsertAndSelectTree :: + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorInsertAndSelectTree f g t fc = + fromMaybe + (forestCursorInsertAndSelectTreeCursor + f + (makeTreeCursor g $ makeCTree t) + fc) $ + fc & forestCursorSelectedTreeL (treeCursorInsertAndSelect f g t) + +forestCursorAppendTree :: Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendTree t fc = + fromMaybe (forestCursorAppendEntireTree t fc) $ + fc & forestCursorSelectedTreeL (treeCursorAppend t) + +forestCursorAppendAndSelectTree :: + (a -> b) -> (b -> a) -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAppendAndSelectTree f g t fc = + fromMaybe + (forestCursorAppendAndSelectTreeCursor + f + (makeTreeCursor g $ makeCTree t) + fc) $ + fc & forestCursorSelectedTreeL (treeCursorAppendAndSelect f g t) + +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 +forestCursorInsertAndSelect f g 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 +forestCursorAppendAndSelect f g b = + forestCursorAppendAndSelectTree f g $ Node b [] + +forestCursorAddChildTreeToNodeAtPos :: + Int -> Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtPos i t = + forestCursorSelectedTreeL %~ treeCursorAddChildAtPos i t + +forestCursorAddChildTreeToNodeAtStart :: + Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtStart t = + forestCursorSelectedTreeL %~ treeCursorAddChildAtStart t + +forestCursorAddChildTreeToNodeAtEnd :: + Tree b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildTreeToNodeAtEnd t fc = + fc & forestCursorSelectedTreeL %~ treeCursorAddChildAtEnd t + +forestCursorAddChildToNodeAtPos :: + Int -> b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtPos i b = + forestCursorAddChildTreeToNodeAtPos i $ Node b [] + +forestCursorAddChildToNodeAtStart :: b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtStart b = + forestCursorAddChildTreeToNodeAtStart $ Node b [] + +forestCursorAddChildToNodeAtEnd :: b -> ForestCursor a b -> ForestCursor a b +forestCursorAddChildToNodeAtEnd b = + forestCursorAddChildTreeToNodeAtEnd $ Node b [] + +forestCursorRemoveElemAndSelectPrev :: + (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 + +forestCursorDeleteElemAndSelectNext :: + (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 + +forestCursorRemoveElem :: + (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) +forestCursorRemoveElem g fc = + (fc & forestCursorSelectedTreeL (treeCursorRemoveElem g)) <|> + (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) + +forestCursorDeleteElem :: + (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) +forestCursorDeleteElem g fc = + (fc & forestCursorSelectedTreeL (treeCursorDeleteElem g)) <|> + (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) + +forestCursorRemoveSubTreeAndSelectPrev :: + (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))) + +forestCursorDeleteSubTreeAndSelectNext :: + (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))) + +forestCursorRemoveSubTree :: + (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) +forestCursorRemoveSubTree g fc = + (fc & forestCursorSelectedTreeL (treeCursorRemoveSubTree g)) <|> + (fc & forestCursorListCursorL (nonEmptyCursorRemoveElem (makeTreeCursor g))) + +forestCursorDeleteSubTree :: + (b -> a) -> ForestCursor a b -> DeleteOrUpdate (ForestCursor a b) +forestCursorDeleteSubTree g fc = + (fc & forestCursorSelectedTreeL (treeCursorDeleteSubTree g)) <|> + (fc & forestCursorListCursorL (nonEmptyCursorDeleteElem (makeTreeCursor g))) + +forestCursorAddRoot :: + (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 + +-- | Swaps the current node with the previous node on the same level +-- +-- Example: +-- +-- Before: +-- +-- > - a +-- > - b <-- +-- +-- After: +-- +-- > - b <-- +-- > - 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 + } + +-- | Swaps the current node with the next node on the same level +-- +-- Example: +-- +-- Before: +-- +-- > - a <-- +-- > - b +-- +-- After: +-- +-- > - b +-- > - 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 + } + +-- | Promotes the current node to the level of its parent. +-- +-- Example: +-- +-- Before: +-- +-- > - a +-- > |- b +-- > | |- c +-- > |- d <-- +-- > | |- e +-- > |- f +-- > |- g +-- > - h +-- +-- After: +-- +-- > - a +-- > |- b +-- > | |- c +-- > | |- e +-- > |- f +-- > |- g +-- > - d <-- +-- > - h +forestCursorPromoteElem :: + (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 + } + +-- | Promotes the current node to the level of its parent. +-- +-- Example: +-- +-- Before: +-- +-- > - a +-- > |- b +-- > | |- c +-- > |- d <-- +-- > | |- e +-- > |- f +-- > |- g +-- > - h +-- +-- After: +-- +-- > +-- > - a +-- > |- b +-- > | |- c +-- > |- f +-- > |- g +-- > - d <-- +-- > |- e +-- > - h +forestCursorPromoteSubTree :: + (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} + } + +-- | Demotes the current node to the level of its children. +-- +-- Example: +-- +-- Before: +-- +-- > - a +-- > |- b +-- > - c <-- +-- > |- d +-- > - e +-- +-- After: +-- +-- > - a +-- > |- b +-- > |- c <-- +-- > |- d +-- > - e +forestCursorDemoteElem :: + (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 + +-- | Demotes the current subtree to the level of its children. +-- +-- Example: +-- +-- Before: +-- +-- > - a +-- > |- b +-- > - c <-- +-- > |- d +-- +-- After: +-- +-- > - a +-- > |- b +-- > |- c <-- +-- > |- d +forestCursorDemoteSubTree :: + (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 + +-- | 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. +-- +-- Example: +-- +-- Before: +-- +-- > - a <-- +-- > |- b +-- +-- After: +-- +-- > - +-- > |- a <-- +-- > - +-- > |- 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 + } + +-- | Demotes the current subtree to the level of its children, by adding a root. +-- +-- Example: +-- +-- Before: +-- +-- > a <-- +-- > |- b +-- +-- After: +-- +-- > +-- > |- a <-- +-- > |- b +forestCursorDemoteSubTreeUnder :: b -> ForestCursor a b -> ForestCursor a b +forestCursorDemoteSubTreeUnder b = + forestCursorSelectedTreeL %~ treeCursorDemoteSubTreeUnder b diff --git a/src/Cursor/List.hs b/src/Cursor/List.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/List.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.List + ( ListCursor(..) + , emptyListCursor + , makeListCursor + , makeListCursorWithSelection + , rebuildListCursor + , listCursorNull + , listCursorLength + , listCursorIndex + , listCursorSelectPrev + , listCursorSelectNext + , listCursorSelectIndex + , listCursorSelectStart + , listCursorSelectEnd + , listCursorPrevItem + , listCursorNextItem + , listCursorInsert + , listCursorAppend + , listCursorRemove + , listCursorDelete + , listCursorSplit + , listCursorCombine + ) where + +import GHC.Generics (Generic) + +import Data.Validity + +data ListCursor a = ListCursor + { listCursorPrev :: [a] -- ^ In reverse order + , listCursorNext :: [a] + } deriving (Show, Eq, Generic, Functor) + +instance Validity a => Validity (ListCursor a) + +emptyListCursor :: ListCursor a +emptyListCursor = ListCursor {listCursorPrev = [], listCursorNext = []} + +makeListCursor :: [a] -> ListCursor a +makeListCursor as = ListCursor {listCursorPrev = [], listCursorNext = as} + +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 + } + +rebuildListCursor :: ListCursor a -> [a] +rebuildListCursor ListCursor {..} = reverse listCursorPrev ++ listCursorNext + +listCursorNull :: ListCursor a -> Bool +listCursorNull ListCursor {..} = null listCursorPrev && null listCursorNext + +listCursorLength :: ListCursor a -> Int +listCursorLength = length . rebuildListCursor + +listCursorIndex :: ListCursor a -> Int +listCursorIndex = length . listCursorPrev + +listCursorSelectPrev :: ListCursor a -> Maybe (ListCursor a) +listCursorSelectPrev 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 + } + +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} + +listCursorSelectStart :: ListCursor a -> ListCursor a +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' + +listCursorPrevItem :: ListCursor a -> Maybe a +listCursorPrevItem lc = + case listCursorPrev lc of + [] -> Nothing + (c:_) -> Just c + +listCursorNextItem :: ListCursor a -> Maybe a +listCursorNextItem lc = + case listCursorNext lc of + [] -> Nothing + (c:_) -> Just c + +listCursorInsert :: a -> ListCursor a -> ListCursor a +listCursorInsert c lc = lc {listCursorPrev = c : listCursorPrev lc} + +listCursorAppend :: a -> ListCursor a -> ListCursor a +listCursorAppend c lc = lc {listCursorNext = c : listCursorNext lc} + +listCursorRemove :: ListCursor a -> Maybe (ListCursor a) +listCursorRemove tc = + case listCursorPrev tc of + [] -> Nothing + (_:prev) -> Just $ tc {listCursorPrev = prev} + +listCursorDelete :: ListCursor a -> Maybe (ListCursor a) +listCursorDelete tc = + case listCursorNext tc of + [] -> Nothing + (_:next) -> Just $ tc {listCursorNext = next} + +listCursorSplit :: ListCursor a -> (ListCursor a, ListCursor a) +listCursorSplit ListCursor {..} = + ( 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 + } diff --git a/src/Cursor/List/NonEmpty.hs b/src/Cursor/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/List/NonEmpty.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.List.NonEmpty + ( NonEmptyCursor(..) + , makeNonEmptyCursor + , makeNonEmptyCursorWithSelection + , singletonNonEmptyCursor + , rebuildNonEmptyCursor + , nonEmptyCursorElemL + , mapNonEmptyCursor + , nonEmptyCursorSelectPrev + , nonEmptyCursorSelectNext + , nonEmptyCursorSelectFirst + , nonEmptyCursorSelectLast + , nonEmptyCursorSelection + , nonEmptyCursorSelectIndex + , nonEmptyCursorInsert + , nonEmptyCursorAppend + , nonEmptyCursorInsertAndSelect + , nonEmptyCursorAppendAndSelect + , nonEmptyCursorInsertAtStart + , nonEmptyCursorAppendAtEnd + , nonEmptyCursorInsertAtStartAndSelect + , nonEmptyCursorAppendAtEndAndSelect + , nonEmptyCursorRemoveElemAndSelectPrev + , nonEmptyCursorDeleteElemAndSelectNext + , nonEmptyCursorRemoveElem + , nonEmptyCursorDeleteElem + , nonEmptyCursorSearch + , nonEmptyCursorSelectOrAdd + , nonemptyPrepend + , nonemptyAppend + ) where + +import GHC.Generics (Generic) + +import Data.Validity + +import Data.Maybe + +import Control.Monad + +import Lens.Micro + +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.List.NonEmpty as NE + +import Cursor.Types + +-- | A 'nonempty list' cursor +data NonEmptyCursor a b = NonEmptyCursor + { nonEmptyCursorPrev :: [b] -- In reverse order + , nonEmptyCursorCurrent :: a + , nonEmptyCursorNext :: [b] + } deriving (Show, Eq, Generic, Functor) + +instance (Validity a, Validity b) => Validity (NonEmptyCursor a b) + +makeNonEmptyCursor :: (b -> a) -> NonEmpty b -> NonEmptyCursor a b +makeNonEmptyCursor g = fromJust . makeNonEmptyCursorWithSelection g 0 + +makeNonEmptyCursorWithSelection :: + (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 + } + 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) + +singletonNonEmptyCursor :: a -> NonEmptyCursor a b +singletonNonEmptyCursor a = + NonEmptyCursor + { nonEmptyCursorPrev = [] + , nonEmptyCursorCurrent = a + , nonEmptyCursorNext = [] + } + +rebuildNonEmptyCursor :: (a -> b) -> NonEmptyCursor a b -> NonEmpty b +rebuildNonEmptyCursor f NonEmptyCursor {..} = + nonemptyPrepend (reverse nonEmptyCursorPrev) $ + f nonEmptyCursorCurrent :| nonEmptyCursorNext + +mapNonEmptyCursor :: + (a -> c) -> (b -> d) -> NonEmptyCursor a b -> NonEmptyCursor c d +mapNonEmptyCursor f g NonEmptyCursor {..} = + NonEmptyCursor + { nonEmptyCursorPrev = map g nonEmptyCursorPrev + , nonEmptyCursorCurrent = f nonEmptyCursorCurrent + , nonEmptyCursorNext = map g nonEmptyCursorNext + } + +nonEmptyCursorElemL :: Lens (NonEmptyCursor a c) (NonEmptyCursor b c) a b +nonEmptyCursorElemL = + lens nonEmptyCursorCurrent $ \lec le -> lec {nonEmptyCursorCurrent = le} + +nonEmptyCursorSelectPrev :: + (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 + } + +nonEmptyCursorSelectNext :: + (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 + } + +nonEmptyCursorSelectFirst :: + (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' + +nonEmptyCursorSelectLast :: + (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' + +nonEmptyCursorSelection :: NonEmptyCursor a b -> Int +nonEmptyCursorSelection = length . nonEmptyCursorPrev + +nonEmptyCursorSelectIndex :: + (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 + +nonEmptyCursorInsert :: b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorInsert c lec = + lec {nonEmptyCursorPrev = c : nonEmptyCursorPrev lec} + +nonEmptyCursorAppend :: b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorAppend c lec = + lec {nonEmptyCursorNext = c : nonEmptyCursorNext lec} + +nonEmptyCursorInsertAndSelect :: + (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorInsertAndSelect f c lec = + lec + { nonEmptyCursorCurrent = c + , nonEmptyCursorNext = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorNext lec + } + +nonEmptyCursorAppendAndSelect :: + (a -> b) -> a -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorAppendAndSelect f c lec = + lec + { nonEmptyCursorCurrent = c + , nonEmptyCursorPrev = + f (nonEmptyCursorCurrent lec) : nonEmptyCursorPrev lec + } + +nonEmptyCursorInsertAtStart :: b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorInsertAtStart c lec = + lec {nonEmptyCursorPrev = nonEmptyCursorPrev lec ++ [c]} + +nonEmptyCursorAppendAtEnd :: b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorAppendAtEnd c lec = + lec {nonEmptyCursorNext = nonEmptyCursorNext lec ++ [c]} + +nonEmptyCursorInsertAtStartAndSelect :: + (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorInsertAtStartAndSelect f g c = + nonEmptyCursorSelectFirst f g . nonEmptyCursorInsertAtStart c + +nonEmptyCursorAppendAtEndAndSelect :: + (a -> b) -> (b -> a) -> b -> NonEmptyCursor a b -> NonEmptyCursor a b +nonEmptyCursorAppendAtEndAndSelect f g c = + nonEmptyCursorSelectLast f g . nonEmptyCursorAppendAtEnd c + +nonEmptyCursorRemoveElemAndSelectPrev :: + (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} + +-- 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)) +nonEmptyCursorDeleteElemAndSelectNext g lec = + 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) +nonEmptyCursorRemoveElem g lec = + joinDeletes + (nonEmptyCursorRemoveElemAndSelectPrev g lec) + (nonEmptyCursorDeleteElemAndSelectNext g lec) + +nonEmptyCursorDeleteElem :: + (b -> a) -> NonEmptyCursor a b -> DeleteOrUpdate (NonEmptyCursor a b) +nonEmptyCursorDeleteElem g lec = + joinDeletes + (nonEmptyCursorDeleteElemAndSelectNext g lec) + (nonEmptyCursorRemoveElemAndSelectPrev g lec) + +nonEmptyCursorSearch :: + (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 + 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' + +nonEmptyCursorSelectOrAdd :: + (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' + +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) diff --git a/src/Cursor/Map.hs b/src/Cursor/Map.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Map.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveFunctor #-} +{-# 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 + +import GHC.Generics (Generic) + +import Data.Validity +import Data.Validity.Tree () + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe + +import Lens.Micro + +import Cursor.List.NonEmpty +import Cursor.Map.KeyValue +import Cursor.Types + +newtype MapCursor kc vc k v = MapCursor + { mapCursorList :: NonEmptyCursor (KeyValueCursor kc vc k v) (k, v) + } deriving (Show, Eq, Generic) + +instance (Validity kc, Validity vc, Validity k, Validity v) => + Validity (MapCursor kc vc k v) + +makeMapCursor :: (k -> kc) -> NonEmpty (k, v) -> MapCursor kc vc k v +makeMapCursor h = fromJust . makeMapCursorWithSelection h 0 + +makeMapCursorWithSelection :: + (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 + +singletonMapCursorKey :: kc -> v -> MapCursor kc vc k v +singletonMapCursorKey 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} + +rebuildMapCursor :: + (kc -> k) -> (vc -> v) -> MapCursor kc vc k v -> NonEmpty (k, v) +rebuildMapCursor f g = + rebuildNonEmptyCursor (rebuildKeyValueCursor f g) . mapCursorList + +mapMapCursor :: + (kc -> lc) + -> (vc -> wc) + -> (k -> l) + -> (v -> w) + -> MapCursor kc vc k v + -> MapCursor lc wc l w +mapMapCursor a b c d = + mapCursorNonEmptyCursorL %~ + mapNonEmptyCursor (mapKeyValueCursor a b c d) (\(k, v) -> (c k, d v)) + +mapCursorNonEmptyCursorL :: + Lens (MapCursor kc vc k v) (MapCursor lc wc l w) (NonEmptyCursor (KeyValueCursor kc vc k v) ( k + , v)) (NonEmptyCursor (KeyValueCursor lc wc l w) ( l + , w)) +mapCursorNonEmptyCursorL = + 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 +mapCursorSelectKey g h = mapCursorElemL %~ keyValueCursorSelectKey g h + +mapCursorSelectValue :: + (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 +mapCursorToggleSelected f g h i = + mapCursorElemL %~ keyValueCursorToggleSelected f g h i + +mapCursorSelectPrev :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> MapCursor kc vc k v + -> Maybe (MapCursor kc vc k v) +mapCursorSelectPrev f g h = + mapCursorNonEmptyCursorL $ nonEmptyCursorSelectPrev (rebuild f h) (make g) + +mapCursorSelectNext :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> MapCursor kc vc k v + -> Maybe (MapCursor kc vc k v) +mapCursorSelectNext f g h = + mapCursorNonEmptyCursorL $ nonEmptyCursorSelectNext (rebuild f h) (make g) + +mapCursorSelectFirst :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> MapCursor kc vc k v + -> MapCursor kc vc k v +mapCursorSelectFirst f g h = + mapCursorNonEmptyCursorL %~ + (nonEmptyCursorSelectFirst (rebuild f h) (make g)) + +mapCursorSelectLast :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> MapCursor kc vc k v + -> MapCursor kc vc k v +mapCursorSelectLast f g h = + 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) +mapCursorSelectIndex f g h 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)) + +mapCursorAppend :: k -> v -> MapCursor kc vc k v -> MapCursor kc vc k v +mapCursorAppend k v = mapCursorNonEmptyCursorL %~ (nonEmptyCursorAppend (k, v)) + +mapCursorInsertAndSelectKey :: + (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)) + +mapCursorAppendAndSelectKey :: + (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)) + +mapCursorInsertAndSelectValue :: + (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)) + +mapCursorAppendAndSelectValue :: + (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)) + +mapCursorRemoveElemAndSelectPrev :: + (k -> kc) + -> MapCursor kc vc k v + -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) +mapCursorRemoveElemAndSelectPrev g = + focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ + nonEmptyCursorRemoveElemAndSelectPrev (make g) + +mapCursorDeleteElemAndSelectNext :: + (k -> kc) + -> MapCursor kc vc k v + -> Maybe (DeleteOrUpdate (MapCursor kc vc k v)) +mapCursorDeleteElemAndSelectNext g = + focusPossibleDeleteOrUpdate mapCursorNonEmptyCursorL $ + nonEmptyCursorDeleteElemAndSelectNext (make g) + +mapCursorRemoveElem :: + (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) +mapCursorRemoveElem g = + mapCursorNonEmptyCursorL $ nonEmptyCursorRemoveElem (make g) + +mapCursorDeleteElem :: + (k -> kc) -> MapCursor kc vc k v -> DeleteOrUpdate (MapCursor kc vc k v) +mapCursorDeleteElem g = + mapCursorNonEmptyCursorL $ nonEmptyCursorDeleteElem (make g) + +mapCursorSearch :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> (k -> v -> Bool) + -> MapCursor kc vc k v + -> Maybe (MapCursor kc vc k v) +mapCursorSearch f g h p = + mapCursorNonEmptyCursorL $ + nonEmptyCursorSearch (rebuild f h) (make g) (uncurry p . rebuild f h) + +mapCursorSelectOrAdd :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> (k -> v -> Bool) + -> KeyValueCursor kc vc k v + -> MapCursor kc vc k v + -> MapCursor kc vc k v +mapCursorSelectOrAdd f g h p 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 diff --git a/src/Cursor/Map/KeyValue.hs b/src/Cursor/Map/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Map/KeyValue.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.Map.KeyValue + ( KeyValueCursor(..) + , makeKeyValueCursorKey + , makeKeyValueCursorValue + , rebuildKeyValueCursor + , keyValueCursorSelection + , mapKeyValueCursor + , keyValueCursorSelectKey + , keyValueCursorSelectValue + , keyValueCursorToggleSelected + , KeyValueToggle(..) + ) where + +import GHC.Generics (Generic) + +import Data.Validity + +data KeyValueCursor kc vc k v + = KeyValueCursorKey kc + v + | KeyValueCursorValue k + vc + deriving (Show, Eq, Generic) + +instance (Validity kc, Validity vc, Validity k, Validity v) => + Validity (KeyValueCursor kc vc k v) + +makeKeyValueCursorKey :: kc -> v -> KeyValueCursor kc vc k v +makeKeyValueCursorKey = KeyValueCursorKey + +makeKeyValueCursorValue :: k -> vc -> KeyValueCursor kc vc k v +makeKeyValueCursorValue = KeyValueCursorValue + +rebuildKeyValueCursor :: + (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) + +keyValueCursorSelection :: KeyValueCursor kc vc k v -> KeyValueToggle +keyValueCursorSelection (KeyValueCursorKey _ _) = KeySelected +keyValueCursorSelection (KeyValueCursorValue _ _) = ValueSelected + +mapKeyValueCursor :: + (kc -> lc) + -> (vc -> wc) + -> (k -> l) + -> (v -> w) + -> KeyValueCursor kc vc k v + -> KeyValueCursor lc wc l w +mapKeyValueCursor a b c d kvc = + case kvc of + KeyValueCursorKey kc v -> KeyValueCursorKey (a kc) (d v) + KeyValueCursorValue k vc -> KeyValueCursorValue (c k) (b vc) + +keyValueCursorSelectKey :: + (k -> kc) + -> (vc -> v) + -> KeyValueCursor kc vc k v + -> KeyValueCursor kc vc k v +keyValueCursorSelectKey g h kvc = + case kvc of + KeyValueCursorValue k vc -> KeyValueCursorKey (g k) (h vc) + _ -> kvc + +keyValueCursorSelectValue :: + (kc -> k) + -> (v -> vc) + -> KeyValueCursor kc vc k v + -> KeyValueCursor kc vc k v +keyValueCursorSelectValue f i kvc = + case kvc of + KeyValueCursorKey kc v -> KeyValueCursorValue (f kc) (i v) + _ -> kvc + +keyValueCursorToggleSelected :: + (kc -> k) + -> (k -> kc) + -> (vc -> v) + -> (v -> vc) + -> KeyValueCursor kc vc k v + -> KeyValueCursor kc vc k v +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) + +data KeyValueToggle + = KeySelected + | ValueSelected + deriving (Show, Eq, Generic) + +instance Validity KeyValueToggle diff --git a/src/Cursor/Simple/Forest.hs b/src/Cursor/Simple/Forest.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Forest.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 + +import Data.Validity.Tree () + +import Data.List.NonEmpty (NonEmpty) +import Data.Tree + +import qualified Cursor.Forest as FC +import Cursor.Simple.Tree +import Cursor.Types + +type ForestCursor a = FC.ForestCursor a a + +makeForestCursor :: NonEmpty (CTree a) -> ForestCursor a +makeForestCursor = FC.makeForestCursor id + +rebuildForestCursor :: ForestCursor a -> NonEmpty (CTree a) +rebuildForestCursor = FC.rebuildForestCursor id + +mapForestCursor :: (a -> b) -> ForestCursor a -> ForestCursor b +mapForestCursor f = FC.mapForestCursor f f + +forestCursorSelectPrevTreeCursor :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectPrevTreeCursor = FC.forestCursorSelectPrevTreeCursor id id + +forestCursorSelectNextTreeCursor :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectNextTreeCursor = FC.forestCursorSelectNextTreeCursor id id + +forestCursorSelectFirstTreeCursor :: ForestCursor a -> ForestCursor a +forestCursorSelectFirstTreeCursor = FC.forestCursorSelectFirstTreeCursor id id + +forestCursorSelectLastTreeCursor :: ForestCursor a -> ForestCursor a +forestCursorSelectLastTreeCursor = FC.forestCursorSelectLastTreeCursor id id + +forestCursorSelectNext :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectNext = FC.forestCursorSelectNext id id + +forestCursorSelectPrev :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectPrev = FC.forestCursorSelectPrev id id + +forestCursorSelectNextOnSameLevel :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectNextOnSameLevel = FC.forestCursorSelectNextOnSameLevel id id + +forestCursorSelectPrevOnSameLevel :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectPrevOnSameLevel = FC.forestCursorSelectPrevOnSameLevel id id + +forestCursorSelectFirst :: ForestCursor a -> ForestCursor a +forestCursorSelectFirst = FC.forestCursorSelectFirst id id + +forestCursorSelectLast :: ForestCursor a -> ForestCursor a +forestCursorSelectLast = FC.forestCursorSelectLast id id + +forestCursorSelectBelowAtPos :: Int -> ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectBelowAtPos = FC.forestCursorSelectBelowAtPos id id + +forestCursorSelectBelowAtStart :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectBelowAtStart = FC.forestCursorSelectBelowAtStart id id + +forestCursorSelectBelowAtEnd :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectBelowAtEnd = FC.forestCursorSelectBelowAtEnd id id + +forestCursorSelectIndex :: Int -> ForestCursor a -> Maybe (ForestCursor a) +forestCursorSelectIndex = FC.forestCursorSelectIndex id id + +forestCursorInsertAndSelectTreeCursor :: + TreeCursor a -> ForestCursor a -> ForestCursor a +forestCursorInsertAndSelectTreeCursor = + FC.forestCursorInsertAndSelectTreeCursor id + +forestCursorAppendAndSelectTreeCursor :: + TreeCursor a -> ForestCursor a -> ForestCursor a +forestCursorAppendAndSelectTreeCursor = + FC.forestCursorAppendAndSelectTreeCursor id + +forestCursorInsertAndSelectTree :: Tree a -> ForestCursor a -> ForestCursor a +forestCursorInsertAndSelectTree = FC.forestCursorInsertAndSelectTree id id + +forestCursorAppendAndSelectTree :: Tree a -> ForestCursor a -> ForestCursor a +forestCursorAppendAndSelectTree = FC.forestCursorAppendAndSelectTree id id + +forestCursorInsertAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorInsertAndSelect = FC.forestCursorInsertAndSelect id id + +forestCursorAppendAndSelect :: a -> ForestCursor a -> ForestCursor a +forestCursorAppendAndSelect = FC.forestCursorAppendAndSelect id id + +forestCursorRemoveElemAndSelectPrev :: + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) +forestCursorRemoveElemAndSelectPrev = FC.forestCursorRemoveElemAndSelectPrev id + +forestCursorDeleteElemAndSelectNext :: + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) +forestCursorDeleteElemAndSelectNext = FC.forestCursorDeleteElemAndSelectNext id + +forestCursorRemoveElem :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) +forestCursorRemoveElem = FC.forestCursorRemoveElem id + +forestCursorDeleteElem :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) +forestCursorDeleteElem = FC.forestCursorDeleteElem id + +forestCursorRemoveSubTreeAndSelectPrev :: + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) +forestCursorRemoveSubTreeAndSelectPrev = + FC.forestCursorRemoveSubTreeAndSelectPrev id + +forestCursorDeleteSubTreeAndSelectNext :: + ForestCursor a -> Maybe (DeleteOrUpdate (ForestCursor a)) +forestCursorDeleteSubTreeAndSelectNext = + FC.forestCursorDeleteSubTreeAndSelectNext id + +forestCursorRemoveSubTree :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) +forestCursorRemoveSubTree = FC.forestCursorRemoveSubTree id + +forestCursorDeleteSubTree :: ForestCursor a -> DeleteOrUpdate (ForestCursor a) +forestCursorDeleteSubTree = FC.forestCursorDeleteSubTree id + +forestCursorAddRoot :: ForestCursor a -> a -> TreeCursor a +forestCursorAddRoot = FC.forestCursorAddRoot id id + +forestCursorPromoteElem :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorPromoteElem = FC.forestCursorPromoteElem id id + +forestCursorPromoteSubTree :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorPromoteSubTree = FC.forestCursorPromoteSubTree id id + +forestCursorDemoteElem :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorDemoteElem = FC.forestCursorDemoteElem id id + +forestCursorDemoteSubTree :: ForestCursor a -> Maybe (ForestCursor a) +forestCursorDemoteSubTree = FC.forestCursorDemoteSubTree id id diff --git a/src/Cursor/Simple/List/NonEmpty.hs b/src/Cursor/Simple/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/List/NonEmpty.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 + +import Data.List.NonEmpty (NonEmpty(..)) + +import Cursor.Types + +import qualified Cursor.List.NonEmpty as NEC + +-- | A 'nonempty list' cursor +type NonEmptyCursor a = NEC.NonEmptyCursor a a + +makeNonEmptyCursor :: NonEmpty a -> NonEmptyCursor a +makeNonEmptyCursor = NEC.makeNonEmptyCursor id + +makeNonEmptyCursorWithSelection :: Int -> NonEmpty a -> Maybe (NonEmptyCursor a) +makeNonEmptyCursorWithSelection = NEC.makeNonEmptyCursorWithSelection id + +rebuildNonEmptyCursor :: NonEmptyCursor a -> NonEmpty a +rebuildNonEmptyCursor = NEC.rebuildNonEmptyCursor id + +mapNonEmptyCursor :: (a -> b) -> NonEmptyCursor a -> NonEmptyCursor b +mapNonEmptyCursor f = NEC.mapNonEmptyCursor f f + +nonEmptyCursorSelectPrev :: NonEmptyCursor a -> Maybe (NonEmptyCursor a) +nonEmptyCursorSelectPrev = NEC.nonEmptyCursorSelectPrev id id + +nonEmptyCursorSelectNext :: NonEmptyCursor a -> Maybe (NonEmptyCursor a) +nonEmptyCursorSelectNext = NEC.nonEmptyCursorSelectNext id id + +nonEmptyCursorSelectFirst :: NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorSelectFirst = NEC.nonEmptyCursorSelectFirst id id + +nonEmptyCursorSelectLast :: NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorSelectLast = NEC.nonEmptyCursorSelectLast id id + +nonEmptyCursorSelectIndex :: Int -> NonEmptyCursor a -> Maybe (NonEmptyCursor a) +nonEmptyCursorSelectIndex = NEC.nonEmptyCursorSelectIndex id id + +nonEmptyCursorInsertAndSelect :: a -> NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorInsertAndSelect = NEC.nonEmptyCursorInsertAndSelect id + +nonEmptyCursorAppendAndSelect :: a -> NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorAppendAndSelect = NEC.nonEmptyCursorAppendAndSelect id + +nonEmptyCursorInsertAtStartAndSelect :: + a -> NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorInsertAtStartAndSelect = + NEC.nonEmptyCursorInsertAtStartAndSelect id id + +nonEmptyCursorAppendAtEndAndSelect :: a -> NonEmptyCursor a -> NonEmptyCursor a +nonEmptyCursorAppendAtEndAndSelect = + NEC.nonEmptyCursorAppendAtEndAndSelect id id + +nonEmptyCursorRemoveElemAndSelectPrev :: + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) +nonEmptyCursorRemoveElemAndSelectPrev = + NEC.nonEmptyCursorRemoveElemAndSelectPrev id + +nonEmptyCursorDeleteElemAndSelectNext :: + NonEmptyCursor a -> Maybe (DeleteOrUpdate (NonEmptyCursor a)) +nonEmptyCursorDeleteElemAndSelectNext = + NEC.nonEmptyCursorDeleteElemAndSelectNext id + +nonEmptyCursorRemoveElem :: + NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) +nonEmptyCursorRemoveElem = NEC.nonEmptyCursorRemoveElem id + +nonEmptyCursorDeleteElem :: + NonEmptyCursor a -> DeleteOrUpdate (NonEmptyCursor a) +nonEmptyCursorDeleteElem = NEC.nonEmptyCursorDeleteElem id + +nonEmptyCursorSearch :: + (a -> Bool) -> NonEmptyCursor a -> Maybe (NonEmptyCursor a) +nonEmptyCursorSearch = NEC.nonEmptyCursorSearch id id + +nonEmptyCursorSelectOrAdd :: + (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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Map.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.Simple.Map + ( MapCursor + , MC.mapCursorList + , makeMapCursor + , makeMapCursorWithSelection + , MC.singletonMapCursorKey + , MC.singletonMapCursorValue + , rebuildMapCursor + , mapMapCursor + , MC.mapCursorNonEmptyCursorL + , MC.mapCursorElemL + , mapCursorSelectKey + , mapCursorSelectValue + , mapCursorToggleSelected + , mapCursorSelectPrev + , mapCursorSelectNext + , mapCursorSelectFirst + , mapCursorSelectLast + , MC.mapCursorSelection + , mapCursorSelectIndex + , MC.mapCursorInsert + , MC.mapCursorAppend + , mapCursorInsertAndSelectKey + , mapCursorAppendAndSelectKey + , mapCursorInsertAndSelectValue + , mapCursorAppendAndSelectValue + , mapCursorRemoveElemAndSelectPrev + , mapCursorDeleteElemAndSelectNext + , mapCursorRemoveElem + , mapCursorDeleteElem + , mapCursorSearch + , mapCursorSelectOrAdd + , module Cursor.Simple.Map.KeyValue + ) where + +import Data.List.NonEmpty (NonEmpty(..)) + +import qualified Cursor.Map as MC +import Cursor.Simple.Map.KeyValue +import Cursor.Types + +type MapCursor k v = MC.MapCursor k v k v + +makeMapCursor :: NonEmpty (k, v) -> MapCursor k v +makeMapCursor = MC.makeMapCursor id + +makeMapCursorWithSelection :: Int -> NonEmpty (k, v) -> Maybe (MapCursor k v) +makeMapCursorWithSelection = MC.makeMapCursorWithSelection id + +rebuildMapCursor :: MapCursor k v -> NonEmpty (k, v) +rebuildMapCursor = MC.rebuildMapCursor id id + +mapMapCursor :: (k -> l) -> (v -> w) -> MapCursor k v -> MapCursor l w +mapMapCursor f g = MC.mapMapCursor f g f g + +mapCursorSelectKey :: MapCursor k v -> MapCursor k v +mapCursorSelectKey = MC.mapCursorSelectKey id id + +mapCursorSelectValue :: MapCursor k v -> MapCursor k v +mapCursorSelectValue = MC.mapCursorSelectValue id id + +mapCursorToggleSelected :: MapCursor k v -> MapCursor k v +mapCursorToggleSelected = MC.mapCursorToggleSelected id id id id + +mapCursorSelectPrev :: MapCursor k v -> Maybe (MapCursor k v) +mapCursorSelectPrev = MC.mapCursorSelectPrev id id id + +mapCursorSelectNext :: MapCursor k v -> Maybe (MapCursor k v) +mapCursorSelectNext = MC.mapCursorSelectNext id id id + +mapCursorSelectFirst :: MapCursor k v -> MapCursor k v +mapCursorSelectFirst = MC.mapCursorSelectFirst id id id + +mapCursorSelectLast :: MapCursor k v -> MapCursor k v +mapCursorSelectLast = MC.mapCursorSelectLast id id id + +mapCursorSelectIndex :: Int -> MapCursor k v -> Maybe (MapCursor k v) +mapCursorSelectIndex = MC.mapCursorSelectIndex id id id + +mapCursorInsertAndSelectKey :: k -> v -> MapCursor k v -> MapCursor k v +mapCursorInsertAndSelectKey = MC.mapCursorInsertAndSelectKey id id + +mapCursorAppendAndSelectKey :: k -> v -> MapCursor k v -> MapCursor k v +mapCursorAppendAndSelectKey = MC.mapCursorAppendAndSelectKey id id + +mapCursorInsertAndSelectValue :: k -> v -> MapCursor k v -> MapCursor k v +mapCursorInsertAndSelectValue = MC.mapCursorInsertAndSelectValue id id + +mapCursorAppendAndSelectValue :: k -> v -> MapCursor k v -> MapCursor k v +mapCursorAppendAndSelectValue = MC.mapCursorAppendAndSelectValue id id + +mapCursorRemoveElemAndSelectPrev :: + MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) +mapCursorRemoveElemAndSelectPrev = MC.mapCursorRemoveElemAndSelectPrev id + +mapCursorDeleteElemAndSelectNext :: + MapCursor k v -> Maybe (DeleteOrUpdate (MapCursor k v)) +mapCursorDeleteElemAndSelectNext = MC.mapCursorDeleteElemAndSelectNext id + +mapCursorRemoveElem :: MapCursor k v -> DeleteOrUpdate (MapCursor k v) +mapCursorRemoveElem = MC.mapCursorRemoveElem id + +mapCursorDeleteElem :: MapCursor k v -> DeleteOrUpdate (MapCursor k v) +mapCursorDeleteElem = MC.mapCursorDeleteElem id + +mapCursorSearch :: (k -> v -> Bool) -> MapCursor k v -> Maybe (MapCursor k v) +mapCursorSearch = MC.mapCursorSearch id id id + +mapCursorSelectOrAdd :: + (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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Map/KeyValue.hs @@ -0,0 +1,36 @@ +{-# 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 + +import qualified Cursor.Map.KeyValue as KVC + +type KeyValueCursor k v = KVC.KeyValueCursor k v k v + +rebuildKeyValueCursor :: KeyValueCursor k v -> (k, v) +rebuildKeyValueCursor = KVC.rebuildKeyValueCursor id id + +mapKeyValueCursor :: + (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 +keyValueCursorSelectKey = KVC.keyValueCursorSelectKey id id + +keyValueCursorSelectValue :: KeyValueCursor k v -> KeyValueCursor k v +keyValueCursorSelectValue = KVC.keyValueCursorSelectValue id id + +keyValueCursorToggleSelected :: KeyValueCursor k v -> KeyValueCursor k v +keyValueCursorToggleSelected = KVC.keyValueCursorToggleSelected id id id id diff --git a/src/Cursor/Simple/Tree.hs b/src/Cursor/Simple/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Simple/Tree.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 + +import Data.Tree + +import Cursor.Types + +import qualified Cursor.Tree as TC +import Cursor.Tree (CTree, TreeAbove(..)) + +type TreeCursor a = TC.TreeCursor a a + +makeTreeCursor :: CTree a -> TreeCursor a +makeTreeCursor = TC.makeTreeCursor id + +makeTreeCursorWithSelection :: + TC.TreeCursorSelection -> CTree a -> Maybe (TreeCursor a) +makeTreeCursorWithSelection = TC.makeTreeCursorWithSelection id id + +singletonTreeCursor :: a -> TreeCursor a +singletonTreeCursor = TC.singletonTreeCursor + +rebuildTreeCursor :: TreeCursor a -> CTree a +rebuildTreeCursor = TC.rebuildTreeCursor id + +mapTreeCursor :: (a -> b) -> TreeCursor a -> TreeCursor b +mapTreeCursor f = TC.mapTreeCursor f f + +treeCursorSelect :: + TC.TreeCursorSelection -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelect = TC.treeCursorSelect id id + +treeCursorSelectPrev :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectPrev = TC.treeCursorSelectPrev id id + +treeCursorSelectNext :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectNext = TC.treeCursorSelectNext id id + +treeCursorSelectFirst :: TreeCursor a -> TreeCursor a +treeCursorSelectFirst = TC.treeCursorSelectFirst id id + +treeCursorSelectLast :: TreeCursor a -> TreeCursor a +treeCursorSelectLast = TC.treeCursorSelectLast id id + +treeCursorSelectAbove :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectAbove = TC.treeCursorSelectAbove id id + +treeCursorSelectBelowAtPos :: Int -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectBelowAtPos = TC.treeCursorSelectBelowAtPos id id + +treeCursorSelectBelowAtStart :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectBelowAtStart = TC.treeCursorSelectBelowAtStart id id + +treeCursorSelectBelowAtEnd :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectBelowAtEnd = TC.treeCursorSelectBelowAtEnd id id + +treeCursorSelectBelowAtStartRecursively :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectBelowAtStartRecursively = + TC.treeCursorSelectBelowAtStartRecursively id id + +treeCursorSelectBelowAtEndRecursively :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectBelowAtEndRecursively = + TC.treeCursorSelectBelowAtEndRecursively id id + +treeCursorSelectPrevOnSameLevel :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectPrevOnSameLevel = TC.treeCursorSelectPrevOnSameLevel id id + +treeCursorSelectNextOnSameLevel :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectNextOnSameLevel = TC.treeCursorSelectNextOnSameLevel id id + +-- | Go back and down as far as necessary to find a previous element on a level below +treeCursorSelectAbovePrev :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectAbovePrev = TC.treeCursorSelectAbovePrev id id + +-- | 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 :: TreeCursor a -> Maybe (TreeCursor a) +treeCursorSelectAboveNext = TC.treeCursorSelectAboveNext id id + +treeCursorInsertAndSelect :: Tree a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorInsertAndSelect = TC.treeCursorInsertAndSelect id id + +treeCursorAppendAndSelect :: Tree a -> TreeCursor a -> Maybe (TreeCursor a) +treeCursorAppendAndSelect = TC.treeCursorAppendAndSelect id id + +treeCursorDeleteSubTreeAndSelectPrevious :: + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) +treeCursorDeleteSubTreeAndSelectPrevious = + TC.treeCursorDeleteSubTreeAndSelectPrevious id + +treeCursorDeleteSubTreeAndSelectNext :: + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) +treeCursorDeleteSubTreeAndSelectNext = + TC.treeCursorDeleteSubTreeAndSelectNext id + +treeCursorDeleteSubTreeAndSelectAbove :: + TreeCursor a -> DeleteOrUpdate (TreeCursor a) +treeCursorDeleteSubTreeAndSelectAbove = + TC.treeCursorDeleteSubTreeAndSelectAbove id + +treeCursorRemoveSubTree :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) +treeCursorRemoveSubTree = TC.treeCursorRemoveSubTree id + +treeCursorDeleteSubTree :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) +treeCursorDeleteSubTree = TC.treeCursorDeleteSubTree id + +treeCursorDeleteElemAndSelectPrevious :: + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) +treeCursorDeleteElemAndSelectPrevious = + TC.treeCursorDeleteElemAndSelectPrevious id + +treeCursorDeleteElemAndSelectNext :: + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) +treeCursorDeleteElemAndSelectNext = TC.treeCursorDeleteElemAndSelectNext id + +treeCursorDeleteElemAndSelectAbove :: + TreeCursor a -> Maybe (DeleteOrUpdate (TreeCursor a)) +treeCursorDeleteElemAndSelectAbove = TC.treeCursorDeleteElemAndSelectAbove id + +treeCursorRemoveElem :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) +treeCursorRemoveElem = TC.treeCursorRemoveElem id + +treeCursorDeleteElem :: TreeCursor a -> DeleteOrUpdate (TreeCursor a) +treeCursorDeleteElem = TC.treeCursorDeleteElem id + +treeCursorPromoteElem :: TreeCursor a -> TC.PromoteElemResult (TreeCursor a) +treeCursorPromoteElem = TC.treeCursorPromoteElem id id + +treeCursorPromoteSubTree :: TreeCursor a -> TC.PromoteResult (TreeCursor a) +treeCursorPromoteSubTree = TC.treeCursorPromoteSubTree id id + +treeCursorDemoteElem :: TreeCursor a -> TC.DemoteResult (TreeCursor a) +treeCursorDemoteElem = TC.treeCursorDemoteElem id id + +treeCursorDemoteSubTree :: TreeCursor a -> TC.DemoteResult (TreeCursor a) +treeCursorDemoteSubTree = TC.treeCursorDemoteSubTree id id diff --git a/src/Cursor/Text.hs b/src/Cursor/Text.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Text.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.Text + ( TextCursor(..) + , emptyTextCursor + , makeTextCursor + , makeTextCursorWithSelection + , rebuildTextCursor + , textCursorNull + , textCursorLength + , textCursorIndex + , textCursorSelectPrev + , textCursorSelectNext + , textCursorSelectIndex + , textCursorSelectStart + , textCursorSelectEnd + , textCursorPrevChar + , textCursorNextChar + , textCursorInsert + , textCursorAppend + , textCursorRemove + , textCursorDelete + , textCursorSplit + , textCursorCombine + ) where + +import Data.Validity +import GHC.Generics (Generic) + +import qualified Data.Text as T +import Data.Text (Text) + +import Lens.Micro + +import Cursor.List + +-- | A cursor for single-line texts +newtype TextCursor = TextCursor + { textCursorList :: ListCursor Char + } 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' + ] + +emptyTextCursor :: TextCursor +emptyTextCursor = TextCursor emptyListCursor + +makeTextCursor :: Text -> Maybe TextCursor +makeTextCursor t = makeTextCursorWithSelection (T.length t) t + +makeTextCursorWithSelection :: Int -> Text -> Maybe TextCursor +makeTextCursorWithSelection i t = + 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 +textCursorListCursorL = lens textCursorList (\tc lc -> tc {textCursorList = lc}) + +textCursorNull :: TextCursor -> Bool +textCursorNull = listCursorNull . textCursorList + +textCursorLength :: TextCursor -> Int +textCursorLength = listCursorLength . textCursorList + +textCursorIndex :: TextCursor -> Int +textCursorIndex = listCursorIndex . textCursorList + +textCursorSelectPrev :: TextCursor -> Maybe TextCursor +textCursorSelectPrev = textCursorListCursorL listCursorSelectPrev + +textCursorSelectNext :: TextCursor -> Maybe TextCursor +textCursorSelectNext = textCursorListCursorL listCursorSelectNext + +textCursorSelectIndex :: Int -> TextCursor -> TextCursor +textCursorSelectIndex ix_ = textCursorListCursorL %~ listCursorSelectIndex ix_ + +textCursorSelectStart :: TextCursor -> TextCursor +textCursorSelectStart = textCursorListCursorL %~ listCursorSelectStart + +textCursorSelectEnd :: TextCursor -> TextCursor +textCursorSelectEnd = textCursorListCursorL %~ listCursorSelectEnd + +textCursorPrevChar :: TextCursor -> Maybe Char +textCursorPrevChar = listCursorPrevItem . textCursorList + +textCursorNextChar :: TextCursor -> Maybe Char +textCursorNextChar = listCursorNextItem . textCursorList + +textCursorInsert :: Char -> TextCursor -> Maybe TextCursor +textCursorInsert '\n' _ = Nothing +textCursorInsert c tc = Just (tc & textCursorListCursorL %~ listCursorInsert c) + +textCursorAppend :: Char -> TextCursor -> Maybe TextCursor +textCursorAppend '\n' _ = Nothing +textCursorAppend c tc = Just (tc & textCursorListCursorL %~ listCursorAppend c) + +textCursorRemove :: TextCursor -> Maybe TextCursor +textCursorRemove = textCursorListCursorL listCursorRemove + +textCursorDelete :: TextCursor -> Maybe TextCursor +textCursorDelete = textCursorListCursorL listCursorDelete + +textCursorSplit :: TextCursor -> (TextCursor, TextCursor) +textCursorSplit tc = + 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} diff --git a/src/Cursor/TextField.hs b/src/Cursor/TextField.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/TextField.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Cursor.TextField + ( TextFieldCursor(..) + , makeTextFieldCursor + , makeTextFieldCursorWithSelection + , rebuildTextFieldCursorLines + , rebuildTextFieldCursor + , emptyTextFieldCursor + , nullTextFieldCursor + , textFieldCursorSelection + , textFieldCursorNonEmptyCursorL + , textFieldCursorSelectedL + , textFieldCursorSelectPrevLine + , textFieldCursorSelectNextLine + , textFieldCursorSelectFirstLine + , textFieldCursorSelectLastLine + , textFieldCursorSelectPrevChar + , textFieldCursorSelectNextChar + , textFieldCursorIndexOnLine + , textFieldCursorSelectIndexOnLine + , textFieldCursorInsertChar + , textFieldCursorAppendChar + , textFieldCursorInsertNewline + , textFieldCursorAppendNewline + , textFieldCursorRemove + , textFieldCursorDelete + , textFieldCursorSelectStartOfLine + , textFieldCursorSelectEndOfLine + ) where + +import GHC.Generics (Generic) + +import Data.Validity +import Data.Validity.Text () + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import qualified Data.Text as T +import Data.Text (Text) + +import Control.Monad + +import Lens.Micro + +import Cursor.List.NonEmpty +import Cursor.Text +import Cursor.Types + +newtype TextFieldCursor = TextFieldCursor + { textFieldCursorNonEmpty :: NonEmptyCursor TextCursor Text + } deriving (Show, Eq, Generic) + +instance Validity TextFieldCursor where + validate tfc@TextFieldCursor {..} = + mconcat + [ genericValidate tfc + , decorate "None of the texts contain newlines" $ + 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 + -- 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 + -- This is safe because we already checked that it would work above + (makeTextCursorWithSelection y) + x + ls + void $ nonEmptyCursorCurrent nec + pure $ TextFieldCursor (nec & nonEmptyCursorElemL %~ fromJust) + +rebuildTextFieldCursorLines :: TextFieldCursor -> NonEmpty Text +rebuildTextFieldCursorLines = + rebuildNonEmptyCursor rebuildTextCursor . textFieldCursorNonEmpty + +rebuildTextFieldCursor :: TextFieldCursor -> Text +rebuildTextFieldCursor = + T.intercalate "\n" . NE.toList . rebuildTextFieldCursorLines + +emptyTextFieldCursor :: TextFieldCursor +emptyTextFieldCursor = + TextFieldCursor + {textFieldCursorNonEmpty = singletonNonEmptyCursor emptyTextCursor} + +nullTextFieldCursor :: TextFieldCursor -> Bool +nullTextFieldCursor = (== emptyTextFieldCursor) + +textFieldCursorSelection :: TextFieldCursor -> (Int, Int) +textFieldCursorSelection tfc = + ( nonEmptyCursorSelection $ textFieldCursorNonEmpty tfc + , textCursorIndex $ textFieldCursorNonEmpty tfc ^. nonEmptyCursorElemL) + +textFieldCursorNonEmptyCursorL :: + Lens' TextFieldCursor (NonEmptyCursor TextCursor Text) +textFieldCursorNonEmptyCursorL = + lens textFieldCursorNonEmpty $ \tfc lec -> + tfc {textFieldCursorNonEmpty = lec} + +textFieldCursorSelectedL :: Lens' TextFieldCursor TextCursor +textFieldCursorSelectedL = textFieldCursorNonEmptyCursorL . nonEmptyCursorElemL + +textFieldCursorSelectPrevLine :: TextFieldCursor -> Maybe TextFieldCursor +textFieldCursorSelectPrevLine = + moveMWhileKeepingSelection $ + nonEmptyCursorSelectPrev rebuildTextCursor unsafeMakeTextCursor + +textFieldCursorSelectNextLine :: TextFieldCursor -> Maybe TextFieldCursor +textFieldCursorSelectNextLine = + moveMWhileKeepingSelection $ + nonEmptyCursorSelectNext rebuildTextCursor unsafeMakeTextCursor + +moveMWhileKeepingSelection :: + (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'' + +textFieldCursorSelectFirstLine :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectFirstLine = + moveWhileKeepingSelection $ + nonEmptyCursorSelectFirst rebuildTextCursor unsafeMakeTextCursor + +textFieldCursorSelectLastLine :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectLastLine = + moveWhileKeepingSelection $ + nonEmptyCursorSelectLast rebuildTextCursor unsafeMakeTextCursor + +moveWhileKeepingSelection :: + (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'' + +textFieldCursorSelectPrevChar :: TextFieldCursor -> Maybe TextFieldCursor +textFieldCursorSelectPrevChar = textFieldCursorSelectedL textCursorSelectPrev + +textFieldCursorSelectNextChar :: TextFieldCursor -> Maybe TextFieldCursor +textFieldCursorSelectNextChar = textFieldCursorSelectedL textCursorSelectNext + +textFieldCursorIndexOnLine :: TextFieldCursor -> Int +textFieldCursorIndexOnLine tfc = + textCursorIndex $ tfc ^. textFieldCursorSelectedL + +textFieldCursorSelectIndexOnLine :: Int -> TextFieldCursor -> TextFieldCursor +textFieldCursorSelectIndexOnLine 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) + +textFieldCursorAppendChar :: Char -> Maybe TextFieldCursor -> TextFieldCursor +textFieldCursorAppendChar c mtfc = + 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 + }) + +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 + }) + +textFieldCursorRemove :: + 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 + +textFieldCursorDelete :: + 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 + +textFieldCursorSelectStartOfLine :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectStartOfLine = + textFieldCursorSelectedL %~ textCursorSelectStart + +textFieldCursorSelectEndOfLine :: TextFieldCursor -> TextFieldCursor +textFieldCursorSelectEndOfLine = textFieldCursorSelectedL %~ textCursorSelectEnd + +-- Unsafe: only use for movements. +unsafeMakeTextCursor :: Text -> TextCursor +unsafeMakeTextCursor = fromJust . makeTextCursor diff --git a/src/Cursor/Tree.hs b/src/Cursor/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +module Cursor.Tree + ( TreeCursor(..) + , TreeAbove(..) + -- * Types + , module Cursor.Tree.Types + -- * Construction, destruction + , module Cursor.Tree.Base + -- * Drawing + , module Cursor.Tree.Draw + -- * Collapsing + , module Cursor.Tree.Collapse + -- * Movements + , module Cursor.Tree.Movement + -- * Insertions + , module Cursor.Tree.Insert + -- * Deletions + , module Cursor.Tree.Delete + -- * Swapping + , module Cursor.Tree.Swap + -- * Promotions + , module Cursor.Tree.Promote + -- * Demotions + , module Cursor.Tree.Demote + ) where + +import Cursor.Tree.Base +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 +import Cursor.Tree.Types diff --git a/src/Cursor/Tree/Base.hs b/src/Cursor/Tree/Base.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Base.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Base + ( singletonTreeCursor + , makeTreeCursor + , makeTreeCursorWithSelection + , rebuildTreeCursor + , mapTreeCursor + , currentTree + , makeTreeCursorWithAbove + ) where + +import Cursor.Tree.Types + +singletonTreeCursor :: a -> TreeCursor a b +singletonTreeCursor v = + 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} + +makeTreeCursorWithSelection :: + (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 + } + +rebuildTreeCursor :: (a -> b) -> TreeCursor a b -> CTree b +rebuildTreeCursor f TreeCursor {..} = + 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] + +mapTreeCursor :: (a -> c) -> (b -> d) -> TreeCursor a b -> TreeCursor c d +mapTreeCursor f g TreeCursor {..} = + TreeCursor + { treeAbove = fmap g <$> treeAbove + , treeCurrent = f treeCurrent + , treeBelow = fmap g treeBelow + } + +currentTree :: (a -> b) -> TreeCursor a b -> CTree b +currentTree f TreeCursor {..} = CNode (f treeCurrent) treeBelow + +makeTreeCursorWithAbove :: + (b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b +makeTreeCursorWithAbove g (CNode a forest) mta = + TreeCursor {treeAbove = mta, treeCurrent = g a, treeBelow = forest} diff --git a/src/Cursor/Tree/Collapse.hs b/src/Cursor/Tree/Collapse.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Collapse.hs @@ -0,0 +1,34 @@ +module Cursor.Tree.Collapse + ( treeCursorCloseCurrentForest + , treeCursorOpenCurrentForest + , treeCursorToggleCurrentForest + ) where + +import qualified Data.List.NonEmpty as NE + +import Cursor.Tree.Types + +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 + +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} + +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} diff --git a/src/Cursor/Tree/Delete.hs b/src/Cursor/Tree/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Delete.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Delete + ( treeCursorDeleteSubTreeAndSelectPrevious + , treeCursorDeleteSubTreeAndSelectNext + , treeCursorDeleteSubTreeAndSelectAbove + , treeCursorRemoveSubTree + , treeCursorDeleteSubTree + , treeCursorDeleteElemAndSelectPrevious + , treeCursorDeleteElemAndSelectNext + , treeCursorDeleteElemAndSelectAbove + , treeCursorRemoveElem + , treeCursorDeleteElem + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Tree + +import Control.Applicative + +import Cursor.Tree.Base +import Cursor.Tree.Types +import Cursor.Types + +treeCursorDeleteSubTreeAndSelectPrevious :: + (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} + +treeCursorDeleteSubTreeAndSelectNext :: + (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} + +treeCursorDeleteSubTreeAndSelectAbove :: + (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 + } + +treeCursorRemoveSubTree :: + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) +treeCursorRemoveSubTree g tc = + joinDeletes + (treeCursorDeleteSubTreeAndSelectPrevious g tc) + (treeCursorDeleteSubTreeAndSelectNext g tc) <|> + treeCursorDeleteSubTreeAndSelectAbove g tc + +treeCursorDeleteSubTree :: + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) +treeCursorDeleteSubTree g tc = + joinDeletes + (treeCursorDeleteSubTreeAndSelectNext g tc) + (treeCursorDeleteSubTreeAndSelectPrevious g tc) <|> + treeCursorDeleteSubTreeAndSelectAbove g tc + +treeCursorDeleteElemAndSelectPrevious :: + (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 + } + +treeCursorDeleteElemAndSelectNext :: + (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 + +treeCursorDeleteElemAndSelectAbove :: + (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 + } + +treeCursorRemoveElem :: + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) +treeCursorRemoveElem g tc = + joinDeletes3 + (treeCursorDeleteElemAndSelectPrevious g tc) + (treeCursorDeleteElemAndSelectNext g tc) + (treeCursorDeleteElemAndSelectAbove g tc) + +treeCursorDeleteElem :: + (b -> a) -> TreeCursor a b -> DeleteOrUpdate (TreeCursor a b) +treeCursorDeleteElem 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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Demote.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Demote + ( treeCursorDemoteElem + , treeCursorDemoteSubTree + , DemoteResult(..) + , treeCursorDemoteElemUnder + , treeCursorDemoteSubTreeUnder + ) where + +import Data.Validity + +import GHC.Generics (Generic) + +import Cursor.Tree.Base +import Cursor.Tree.Types + +-- | Demotes the current node to the level of its children. +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a +-- > | |- b +-- > |- c <-- +-- > | |- d +-- > |- e +-- +-- After: +-- +-- > p +-- > |- a +-- > | |- b +-- > | |- c <-- +-- > | |- d +-- > |- e +treeCursorDemoteElem :: + (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 + } + +-- | Demotes the current subtree to the level of its children. +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a +-- > | |- b +-- > |- c <-- +-- > | |- d +-- > |- e +-- +-- After: +-- +-- > p +-- > |- a +-- > | |- b +-- > | |- c <-- +-- > | |- d +-- > |- e +treeCursorDemoteSubTree :: + (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 = [] + } + +data DemoteResult a + = CannotDemoteTopNode + | NoSiblingsToDemoteUnder + | Demoted a + deriving (Show, Eq, Generic, Functor) + +instance Validity a => Validity (DemoteResult a) + +-- | 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. +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a <-- +-- > |- b +-- +-- After: +-- +-- > p +-- > |- +-- > | |- a <-- +-- > |- +-- > | |- 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 + } + +-- | Demotes the current subtree to the level of its children, by adding a root. +-- +-- Example: +-- +-- Before: +-- +-- > a <-- +-- > |- b +-- +-- After: +-- +-- > +-- > |- a <-- +-- > |- b +treeCursorDemoteSubTreeUnder :: b -> TreeCursor a b -> TreeCursor a b +treeCursorDemoteSubTreeUnder b tc = + tc + { treeAbove = + Just + TreeAbove + { treeAboveLefts = [] + , treeAboveAbove = treeAbove tc + , treeAboveNode = b + , treeAboveRights = [] + } + } diff --git a/src/Cursor/Tree/Draw.hs b/src/Cursor/Tree/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Draw.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Draw + ( drawTreeCursor + , treeCursorWithPointer + , showCForest + , showCTree + , showForest + , showTree + ) where + +import qualified Data.List.NonEmpty as NE +import Data.Tree + +import Cursor.Tree.Types + +drawTreeCursor :: (Show a, Show b) => TreeCursor a b -> String +drawTreeCursor = drawTree . treeCursorWithPointer + +treeCursorWithPointer :: (Show a, Show b) => TreeCursor a b -> Tree String +treeCursorWithPointer TreeCursor {..} = + 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 + ] + +showCForest :: Show a => CForest a -> Forest String +showCForest EmptyCForest = [] +showCForest (ClosedForest ts) = + map (fmap ("hidden: " ++)) $ map showTree $ NE.toList ts +showCForest (OpenForest ts) = map showCTree $ NE.toList ts + +showCTree :: Show a => CTree a -> Tree String +showCTree (CNode n fs) = Node (show n) $ showCForest fs + +showForest :: Show a => Forest a -> Forest String +showForest = map showTree + +showTree :: Show a => Tree a -> Tree String +showTree = fmap show diff --git a/src/Cursor/Tree/Insert.hs b/src/Cursor/Tree/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Insert.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Insert + ( treeCursorInsert + , treeCursorInsertAndSelect + , treeCursorAppend + , treeCursorAppendAndSelect + , treeCursorAddChildAtPos + , treeCursorAddChildAtStart + , treeCursorAddChildAtEnd + ) where + +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ((<|)) +import Data.Tree + +import Cursor.Tree.Base +import Cursor.Tree.Types + +treeCursorInsert :: Tree b -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorInsert tree tc@TreeCursor {..} = do + ta <- treeAbove + 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) +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 + +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} + +treeCursorAppendAndSelect :: + (a -> b) + -> (b -> a) + -> Tree b + -> TreeCursor a b + -> Maybe (TreeCursor a b) +treeCursorAppendAndSelect f g tree tc@TreeCursor {..} = do + ta <- treeAbove + let newTreeAbove = + ta {treeAboveLefts = currentTree f tc : treeAboveLefts ta} + pure $ makeTreeCursorWithAbove g (makeCTree tree) $ Just newTreeAbove + +-- 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} + +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} + +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]} diff --git a/src/Cursor/Tree/Movement.hs b/src/Cursor/Tree/Movement.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Movement.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Movement + ( treeCursorSelection + , TreeCursorSelection(..) + , treeCursorSelect + , treeCursorSelectPrev + , treeCursorSelectNext + , treeCursorSelectFirst + , treeCursorSelectLast + , treeCursorSelectAbove + , treeCursorSelectBelowAtPos + , treeCursorSelectBelowAtStart + , treeCursorSelectBelowAtEnd + , treeCursorSelectBelowAtStartRecursively + , treeCursorSelectBelowAtEndRecursively + , treeCursorSelectPrevOnSameLevel + , treeCursorSelectNextOnSameLevel + , treeCursorSelectAbovePrev + , treeCursorSelectAboveNext + ) where + +import qualified Data.List.NonEmpty as NE +import Data.Validity.Tree () + +import Control.Applicative +import Control.Monad + +import Cursor.Tree.Base +import Cursor.Tree.Types + +treeCursorSelection :: TreeCursor a b -> TreeCursorSelection +treeCursorSelection TreeCursor {..} = wrap treeAbove SelectNode + where + wrap :: Maybe (TreeAbove a) -> TreeCursorSelection -> TreeCursorSelection + wrap Nothing ts = ts + wrap (Just ta) ts = + wrap (treeAboveAbove ta) $ SelectChild (length $ treeAboveLefts ta) ts + +treeCursorSelect :: + (a -> b) + -> (b -> a) + -> TreeCursorSelection + -> TreeCursor a b + -> Maybe (TreeCursor a b) +treeCursorSelect f g sel = + makeTreeCursorWithSelection f g sel . rebuildTreeCursor f + +treeCursorSelectPrev :: + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorSelectPrev f g tc = + treeCursorSelectAbovePrev f g tc <|> treeCursorSelectPrevOnSameLevel f g tc <|> + treeCursorSelectAbove f g tc + +treeCursorSelectNext :: + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorSelectNext f g tc = + treeCursorSelectBelowAtStart f g tc <|> + treeCursorSelectNextOnSameLevel f g tc <|> + treeCursorSelectAboveNext f g tc + +treeCursorSelectFirst :: + (a -> b) -> (b -> a) -> TreeCursor a b -> TreeCursor a b +treeCursorSelectFirst 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 + +treeCursorSelectAbove :: + (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 + +treeCursorSelectBelowAtPos :: + (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 + } + +treeCursorSelectBelowAtStart :: + (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) +treeCursorSelectBelowAtEnd f g 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) +treeCursorSelectBelowAtStartRecursively f g tc = + go <$> treeCursorSelectBelowAtStart f g tc + where + go c = maybe c go $ treeCursorSelectBelowAtStart f g c + +treeCursorSelectBelowAtEndRecursively :: + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorSelectBelowAtEndRecursively 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) +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 + } + +treeCursorSelectNextOnSameLevel :: + (a -> b) -> (b -> a) -> TreeCursor a b -> Maybe (TreeCursor a b) +treeCursorSelectNextOnSameLevel f g tc@TreeCursor {..} = do + ta <- treeAbove + case treeAboveRights ta of + [] -> Nothing + tree:xs -> + 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) +treeCursorSelectAbovePrev 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) +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 + where + go tc_ = do + 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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Promote.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Promote + ( treeCursorPromoteElem + , PromoteElemResult(..) + , treeCursorPromoteSubTree + , PromoteResult(..) + ) where + +import Data.Validity + +import GHC.Generics (Generic) + +import Cursor.Tree.Base +import Cursor.Tree.Types + +-- | Promotes the current node to the level of its parent. +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a +-- > | |- b +-- > | | |- c +-- > | |- d <-- +-- > | | |- e +-- > | |- f +-- > | |- g +-- > |- h +-- +-- After: +-- +-- > p +-- > |- a +-- > | |- b +-- > | | |- c +-- > | | |- e +-- > | |- f +-- > | |- g +-- > |- d <-- +-- > |- h +treeCursorPromoteElem :: + (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 + -- 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 + } + +data PromoteElemResult a + = 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 + +instance Monad PromoteElemResult where + CannotPromoteTopElem >>= _ = CannotPromoteTopElem + NoGrandparentToPromoteElemUnder >>= _ = NoGrandparentToPromoteElemUnder + NoSiblingsToAdoptChildren >>= _ = NoSiblingsToAdoptChildren + PromotedElem a >>= f = f a + +-- | Promotes the current node to the level of its parent. +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a +-- > | |- b +-- > | | |- c +-- > | |- d <-- +-- > | | |- e +-- > | |- f +-- > | |- g +-- > |- h +-- +-- After: +-- +-- > p +-- > |- a +-- > | |- b +-- > | | |- c +-- > | |- f +-- > | |- g +-- > |- d <-- +-- > | |- e +-- > |- h +treeCursorPromoteSubTree :: + (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 + } + +data PromoteResult a + = 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 + +instance Monad PromoteResult where + CannotPromoteTopNode >>= _ = CannotPromoteTopNode + NoGrandparentToPromoteUnder >>= _ = NoGrandparentToPromoteUnder + Promoted a >>= f = f a diff --git a/src/Cursor/Tree/Swap.hs b/src/Cursor/Tree/Swap.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Swap.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Swap + ( treeCursorSwapPrev + , treeCursorSwapNext + , SwapResult(..) + ) where + +import Data.Validity + +import GHC.Generics (Generic) + +import Cursor.Tree.Types + +-- | Swaps the current node with the previous node on the same level +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a +-- > |- b <-- +-- +-- After: +-- +-- > p +-- > |- b <-- +-- > |- 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 + } + } + +-- | Swaps the current node with the next node on the same level +-- +-- Example: +-- +-- Before: +-- +-- > p +-- > |- a <-- +-- > |- b +-- +-- After: +-- +-- > p +-- > |- b +-- > |- 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 + } + } + +data SwapResult a + = 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 new file mode 100644 --- /dev/null +++ b/src/Cursor/Tree/Types.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} + +module Cursor.Tree.Types + ( TreeCursor(..) + , treeCursorAboveL + , treeCursorCurrentL + , treeCursorBelowL + , treeCursorCurrentSubTreeL + , TreeAbove(..) + , treeAboveLeftsL + , treeAboveAboveL + , treeAboveNodeL + , treeAboveRightsL + , TreeCursorSelection(..) + -- * CTree + , CTree(..) + , makeCTree + , cTree + , rebuildCTree + , CForest(..) + , makeCForest + , cForest + , rebuildCForest + , emptyCForest + , openForest + , closedForest + , lengthCForest + , unpackCForest + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Tree +import Data.Validity +import Data.Validity.Tree () + +import GHC.Generics (Generic) + +import Lens.Micro + +data TreeCursor a b = TreeCursor + { treeAbove :: !(Maybe (TreeAbove b)) + , treeCurrent :: !a + , treeBelow :: !(CForest b) + } deriving (Show, Eq, Generic) + +treeCursorAboveL :: Lens' (TreeCursor a b) (Maybe (TreeAbove b)) +treeCursorAboveL = lens treeAbove $ \tc ta -> tc {treeAbove = ta} + +treeCursorCurrentL :: Lens' (TreeCursor a b) a +treeCursorCurrentL = lens treeCurrent $ \tc a -> tc {treeCurrent = a} + +treeCursorBelowL :: Lens' (TreeCursor a b) (CForest b) +treeCursorBelowL = lens treeBelow $ \tc tb -> tc {treeBelow = tb} + +treeCursorCurrentSubTreeL :: Lens' (TreeCursor a b) (a, CForest b) +treeCursorCurrentSubTreeL = + 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 + { treeAboveLefts :: ![CTree b] -- In reverse order + , treeAboveAbove :: !(Maybe (TreeAbove b)) + , treeAboveNode :: !b + , treeAboveRights :: ![CTree b] + } deriving (Show, Eq, Generic, Functor) + +instance Validity b => Validity (TreeAbove b) + +treeAboveLeftsL :: Lens' (TreeAbove b) [CTree b] +treeAboveLeftsL = lens treeAboveLefts $ \ta tal -> ta {treeAboveLefts = tal} + +treeAboveAboveL :: Lens' (TreeAbove b) (Maybe (TreeAbove b)) +treeAboveAboveL = lens treeAboveAbove $ \ta taa -> ta {treeAboveAbove = taa} + +treeAboveNodeL :: Lens' (TreeAbove b) b +treeAboveNodeL = lens treeAboveNode $ \ta a -> ta {treeAboveNode = a} + +treeAboveRightsL :: Lens' (TreeAbove b) [CTree b] +treeAboveRightsL = lens treeAboveRights $ \ta tar -> ta {treeAboveRights = tar} + +data TreeCursorSelection + = SelectNode + | SelectChild !Int + !TreeCursorSelection + deriving (Show, Eq, Generic) + +instance Validity TreeCursorSelection + +data CTree a = + CNode !a + !(CForest a) + deriving (Show, Eq, Generic, Functor) + +instance Validity a => Validity (CTree a) + +makeCTree :: Tree a -> CTree a +makeCTree = cTree False + +cTree :: Bool -> Tree a -> CTree a +cTree b (Node v f) = CNode v $ cForest b f + +rebuildCTree :: CTree a -> Tree a +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) + +instance Validity a => Validity (CForest a) + +makeCForest :: Forest a -> CForest a +makeCForest = cForest True + +cForest :: Bool -> Forest a -> CForest a +cForest b f = + if b + then openForest $ map (cTree b) f + else closedForest f + +rebuildCForest :: CForest a -> Forest a +rebuildCForest EmptyCForest = [] +rebuildCForest (ClosedForest f) = NE.toList f +rebuildCForest (OpenForest ct) = NE.toList $ NE.map rebuildCTree ct + +emptyCForest :: CForest a +emptyCForest = EmptyCForest + +openForest :: [CTree a] -> CForest a +openForest ts = + 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 + +lengthCForest :: CForest a -> Int +lengthCForest EmptyCForest = 0 +lengthCForest (ClosedForest ts) = length ts +lengthCForest (OpenForest ts) = length ts + +unpackCForest :: CForest a -> [CTree a] +unpackCForest EmptyCForest = [] +unpackCForest (ClosedForest ts) = NE.toList $ NE.map makeCTree ts +unpackCForest (OpenForest ts) = NE.toList ts diff --git a/src/Cursor/Types.hs b/src/Cursor/Types.hs new file mode 100644 --- /dev/null +++ b/src/Cursor/Types.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + +module Cursor.Types where + +import GHC.Generics (Generic) + +import Data.Validity + +import Data.Functor.Compose + +import Control.Applicative + +import Lens.Micro + +data DeleteOrUpdate a + = 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) + +instance Applicative DeleteOrUpdate where + 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 + +joinDeletes :: + 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 + +joinDeletes3 :: + 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 + +joinPossibleDeletes :: + 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) +focusPossibleDeleteOrUpdate l func = getCompose . l (Compose . func)