module Data.Text.Zipper
( TextZipper
, mkZipper
, textZipper
, stringZipper
, getText
, currentLine
, cursorPosition
, lineLengths
, moveCursor
, insertChar
, breakLine
, killToEOL
, gotoEOL
, gotoBOL
, deletePrevChar
, deleteChar
, moveRight
, moveLeft
, moveUp
, moveDown
)
where
import Control.Applicative ((<$>))
import Data.Monoid
import qualified Data.Text as T
data TextZipper a =
TZ { toLeft :: a
, toRight :: a
, above :: [a]
, below :: [a]
, fromChar :: Char -> a
, drop_ :: Int -> a -> a
, take_ :: Int -> a -> a
, length_ :: a -> Int
, last_ :: a -> Char
, init_ :: a -> a
, null_ :: a -> Bool
}
instance (Eq a) => Eq (TextZipper a) where
a == b = and [ toLeft a == toLeft b
, toRight a == toRight b
, above a == above b
, below a == below b
]
instance (Show a) => Show (TextZipper a) where
show tz = concat [ "TextZipper { "
, "above = "
, show $ above tz
, "below = "
, show $ below tz
, "toLeft = "
, show $ toLeft tz
, "toRight = "
, show $ toRight tz
, " }"
]
mkZipper :: (Monoid a) =>
(Char -> a)
-> (Int -> a -> a)
-> (Int -> a -> a)
-> (a -> Int)
-> (a -> Char)
-> (a -> a)
-> (a -> Bool)
-> [a]
-> TextZipper a
mkZipper fromCh drp tk lngth lst int nl ls =
let (first, rest) = if null ls
then (mempty, mempty)
else (head ls, tail ls)
in TZ mempty first [] rest fromCh drp tk lngth lst int nl
getText :: (Monoid a) => TextZipper a -> [a]
getText tz = concat [ above tz
, [currentLine tz]
, below tz
]
lineLengths :: (Monoid a) => TextZipper a -> [Int]
lineLengths tz = (length_ tz) <$> concat [ above tz
, [currentLine tz]
, below tz
]
cursorPosition :: TextZipper a -> (Int, Int)
cursorPosition tz = (length $ above tz, length_ tz $ toLeft tz)
moveCursor :: (Monoid a) => (Int, Int) -> TextZipper a -> TextZipper a
moveCursor (row, col) tz =
let t = getText tz
in if row < 0
|| row >= length t
|| col < 0
|| col > length_ tz (t !! row)
then tz
else tz { above = take row t
, below = drop (row + 1) t
, toLeft = take_ tz col (t !! row)
, toRight = drop_ tz col (t !! row)
}
lastLine :: TextZipper a -> Bool
lastLine = (== 0) . length . below
nextLine :: TextZipper a -> a
nextLine = head . below
currentLine :: (Monoid a) => TextZipper a -> a
currentLine tz = (toLeft tz) `mappend` (toRight tz)
insertChar :: (Monoid a) => Char -> TextZipper a -> TextZipper a
insertChar ch tz = tz { toLeft = toLeft tz `mappend` (fromChar tz ch) }
breakLine :: (Monoid a) => TextZipper a -> TextZipper a
breakLine tz =
tz { above = above tz ++ [toLeft tz]
, toLeft = mempty
}
gotoEOL :: (Monoid a) => TextZipper a -> TextZipper a
gotoEOL tz = tz { toLeft = currentLine tz
, toRight = mempty
}
killToEOL :: (Monoid a) => TextZipper a -> TextZipper a
killToEOL tz
| (null_ tz $ toLeft tz) && (null_ tz $ toRight tz) &&
(not $ null $ below tz) =
tz { toRight = head $ below tz
, below = tail $ below tz
}
| otherwise = tz { toRight = mempty
}
deletePrevChar :: (Eq a, Monoid a) => TextZipper a -> TextZipper a
deletePrevChar tz
| moveLeft tz == tz = tz
| otherwise = deleteChar $ moveLeft tz
deleteChar :: (Monoid a) => TextZipper a -> TextZipper a
deleteChar tz
| (not $ null_ tz (toRight tz)) =
tz { toRight = drop_ tz 1 $ toRight tz
}
| null_ tz (toRight tz) && (not $ null $ below tz) =
tz { toRight = head $ below tz
, below = tail $ below tz
}
| otherwise = tz
gotoBOL :: (Monoid a) => TextZipper a -> TextZipper a
gotoBOL tz = tz { toLeft = mempty
, toRight = currentLine tz
}
moveRight :: (Monoid a) => TextZipper a -> TextZipper a
moveRight tz
| not (null_ tz (toRight tz)) =
tz { toLeft = toLeft tz
`mappend` (take_ tz 1 $ toRight tz)
, toRight = drop_ tz 1 (toRight tz)
}
| not $ null (below tz) =
tz { above = above tz ++ [toLeft tz]
, below = tail $ below tz
, toLeft = mempty
, toRight = nextLine tz
}
| otherwise = tz
moveLeft :: (Monoid a) => TextZipper a -> TextZipper a
moveLeft tz
| not $ null_ tz (toLeft tz) =
tz { toLeft = init_ tz $ toLeft tz
, toRight = fromChar tz (last_ tz (toLeft tz))
`mappend` toRight tz
}
| not $ null (above tz) =
tz { above = init $ above tz
, below = currentLine tz : below tz
, toLeft = last $ above tz
, toRight = mempty
}
| otherwise = tz
moveUp :: (Monoid a) => TextZipper a -> TextZipper a
moveUp tz
| (not $ null (above tz)) &&
(length_ tz $ last $ above tz) >= length_ tz (toLeft tz) =
tz { below = currentLine tz : below tz
, above = init $ above tz
, toLeft = take_ tz (length_ tz $ toLeft tz) (last $ above tz)
, toRight = drop_ tz (length_ tz $ toLeft tz) (last $ above tz)
}
| (not $ null (above tz)) =
tz { above = init $ above tz
, below = currentLine tz : below tz
, toLeft = last $ above tz
, toRight = mempty
}
| otherwise = gotoBOL tz
moveDown :: (Monoid a) => TextZipper a -> TextZipper a
moveDown tz
| (not $ lastLine tz) &&
(length_ tz $ nextLine tz) >= length_ tz (toLeft tz) =
tz { below = tail $ below tz
, above = above tz ++ [currentLine tz]
, toLeft = take_ tz (length_ tz $ toLeft tz) (nextLine tz)
, toRight = drop_ tz (length_ tz $ toLeft tz) (nextLine tz)
}
| (not $ null (below tz)) =
tz { above = above tz ++ [currentLine tz]
, below = tail $ below tz
, toLeft = nextLine tz
, toRight = mempty
}
| otherwise = gotoEOL tz
stringZipper :: [String] -> TextZipper String
stringZipper =
mkZipper (:[]) drop take length last init null
textZipper :: [T.Text] -> TextZipper T.Text
textZipper =
mkZipper T.singleton T.drop T.take T.length T.last T.init T.null