{- |
Module : Selection.hs
Description : .
Maintainer : Benjamin Kodera (c)
License : MIT
Stability : stable
The Selection-module handles multiple character selection as well as copy and paste functionality.
-}
module Selection (
handleSelection,
updateCells,
relocateCells,
clear,
getFirstPositions,
getBottomRight,
getMinimum,
pasteReplace,
pasteInsert,
getCellsByPositons,
deselect
)
where
import qualified Data.Map as Map
import Data.IORef
import Control.Monad
import Data.Maybe
import qualified TextAreaContent as TAC
import qualified TextAreaContentUtils as TACU
import qualified Data.List as List
import qualified RedoUndo as History
handleSelection :: TAC.TextAreaContent -> TAC.Position -> TAC.Position -> IO (Bool,[TAC.Position])
handleSelection tac currentPos newPos = do
positions <- TAC.getPositons tac
let selectedEntries = getSelectedEntries positions currentPos newPos
if not (null selectedEntries) then do
cell <- TAC.getCell tac $ head selectedEntries
let isAlreadySelected = snd $ fst $ fromJust cell
updateCells tac selectedEntries $ not isAlreadySelected
return (isAlreadySelected,selectedEntries)
else return (False,[])
updateCells :: TAC.TextAreaContent -> [TAC.Position] -> Bool -> IO TAC.Position
updateCells tac positions value = do
_updateCells tac positions value
return $ getBottomRight positions
_updateCells :: TAC.TextAreaContent -> [TAC.Position] -> Bool -> IO ()
_updateCells _ [] _ = return ()
_updateCells tac (pos:xs) value = do
updateCell tac pos value
_updateCells tac xs value
updateCell :: TAC.TextAreaContent -> TAC.Position -> Bool -> IO ()
updateCell tac pos value = do
cell <- TAC.getCell tac pos
when (isJust cell) $ do
let ((char,_),color) = fromJust cell
TAC.deleteCell tac pos
TAC.putCell tac pos ((char,value),color)
relocateCells :: TAC.TextAreaContent -> [(TAC.Position,(Char,Bool))] -> TAC.Position -> IO TAC.Position
relocateCells tac [] pos = return pos
relocateCells tac content (x,y) = do
let (positions,cells) = List.unzip content
(x1,y1) = getMinimum positions
(x2,y2) = getBottomRight positions
_relocateCells tac positions (List.map fst cells) (x,y) (x1,y1)
return (x+x2-x1,y+y2-y1)
_relocateCells :: TAC.TextAreaContent -> [TAC.Position] -> String -> TAC.Position -> TAC.Position -> IO ()
_relocateCells _ [] _ _ _ = return ()
_relocateCells tac (position:positions) (char:chars) newPos offset = do
relocateCell tac position char newPos offset
_relocateCells tac positions chars newPos offset
relocateCell :: TAC.TextAreaContent -> TAC.Position -> Char -> TAC.Position -> TAC.Position -> IO ()
relocateCell tac pos@(x,y) char (newX,newY) (offsetX,offsetY) =
TAC.putCell tac (newX+x-offsetX,newY+y-offsetY) ((char,False),TAC.defaultColor)
-- | clears a selection and removes all selected characters
clear :: TAC.TextAreaContent -> TAC.Position -> IO (TAC.Position,TAC.Position)
clear tac pos@(x,y) = do
positions <- TAC.getSelectedPositons tac
if not (null positions) then do
cells <- Selection.getCellsByPositons tac positions
History.action tac (getMinimum positions) (TAC.Remove cells)
clearCells tac positions
return (getMinimum positions,getMaximum positions)
else return ((x-1,y),(x-1,y))
clearCells :: TAC.TextAreaContent -> [TAC.Position] -> IO ()
clearCells tac [] = return ()
clearCells tac (x:xs) = do
TAC.deleteCell tac x
clearCells tac xs
getCellsByPositons :: TAC.TextAreaContent -> [TAC.Position] -> IO [(Char,Bool)]
getCellsByPositons _ [] = return []
getCellsByPositons tac positions = _getCellsByPositons tac positions []
_getCellsByPositons :: TAC.TextAreaContent -> [TAC.Position] -> [(Char,Bool)] -> IO [(Char,Bool)]
_getCellsByPositons _ [] cells = return cells
_getCellsByPositons tac (x:xs) cells = do
cell <- TAC.getCell tac x
if isJust cell then do
let (content,_) = fromJust cell
_getCellsByPositons tac xs (content:cells)
else _getCellsByPositons tac xs cells
getSelectedEntries :: [TAC.Position] -> TAC.Position -> TAC.Position -> [TAC.Position]
getSelectedEntries positions (x1,y1) (x2,y2)
-- down
| y2 > y1 = List.filter (\(x,y) -> x >= x1 && y == y1 || y > y1 && y < y2 || x < x2 && y == y2) positions
-- right
| x2 > x1 && y2 == y1 = List.filter (\(x,y) -> x >= x1 && x < x2 && y == y2) positions
-- left
| x2 < x1 && y2 == y1 = List.filter (\(x,y) -> x < x1 && x >= x2 && y == y2) positions
-- up
| otherwise = List.filter (\(x,y) -> x < x1 && y == y1 || y < y1 && y > y2 || x >= x2 && y == y2) positions
getMaximumY :: [TAC.Position] -> TAC.Coord
getMaximumY = Prelude.foldl (\y1 (_,y2) -> max y1 y2) 0
getMaximumX :: [TAC.Position] -> TAC.Coord
getMaximumX = Prelude.foldl (\x1 (x2,_) -> max x1 x2) 0
getMinimumY :: [TAC.Position] -> TAC.Coord
getMinimumY [] = 0
getMinimumY positions = fst $ minimum $ Prelude.map (\(x,y) -> (y,x)) positions
getMinimumX :: [TAC.Position] -> TAC.Coord
getMinimumX [] = 0
getMinimumX positions = fst $ minimum positions
getTopLeft :: [TAC.Position] -> TAC.Position
getTopLeft [] = (0,0)
getTopLeft positions = (getMinimumX positions, getMinimumY positions)
getBottomRight :: [TAC.Position] -> TAC.Position
getBottomRight [] = (0,0)
getBottomRight positions = (x+1,y)
where (y,x) = maximum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions
getMinimum :: [TAC.Position] -> TAC.Position
getMinimum [] = (0,0)
getMinimum positions = (x,y)
where (y,x) = minimum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions
getMaximum :: [TAC.Position] -> TAC.Position
getMaximum [] = (0,0)
getMaximum positions = (x,y)
where (y,x) = maximum $ Prelude.map (\(x1,y1) -> (y1,x1)) positions
getFirstPositions :: [TAC.Position] -> [TAC.Position]
getFirstPositions [] = []
getFirstPositions positions = List.map minimum $ List.groupBy (\(x1,y1) (x2,y2) -> y1 == y2) positions
paste :: TAC.TextAreaContent -> TAC.Position -> Bool -> IO TAC.Position
paste tac pos replace = do
clipboard <- TAC.getClipboard tac
let (clipboardPositions,cells) = List.unzip clipboard
when replace $ shiftSubsequentLines tac pos clipboardPositions
History.action tac pos (TAC.Insert cells)
selectedPositions <- TAC.getSelectedPositons tac
newPos <- relocateCells tac clipboard $
if not (null selectedPositions)
then getMinimum selectedPositions
else pos
clear tac newPos
return newPos
-- | pastes content from clipboard to position in override mode
pasteReplace :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position
pasteReplace tac pos = paste tac pos True
-- | pastes content from clipboard to position in insert mode
pasteInsert :: TAC.TextAreaContent -> TAC.Position -> IO TAC.Position
pasteInsert tac pos = paste tac pos False
shiftSubsequentLines :: TAC.TextAreaContent -> TAC.Position -> [TAC.Position] -> IO ()
shiftSubsequentLines tac pos clipboardPositions = do
let (x1,y1) = getMinimum clipboardPositions
(x2,y2) = getMaximum clipboardPositions
(xShift,yShift) = (abs (x1-x2), abs (y1-y2))
positionsToShiftDown <- TAC.getPositonsFrom tac pos
shiftDownLines tac positionsToShiftDown yShift
TACU.moveChars tac pos (xShift+1,yShift)
shiftDownLines :: TAC.TextAreaContent -> [TAC.Position] -> TAC.Coord -> IO ()
shiftDownLines tac positionsToShiftDown yShift = do
let firsts = getFirstPositions positionsToShiftDown
_shiftDownLines tac firsts yShift
_shiftDownLines tac [] _ = return ()
_shiftDownLines _ _ 0 = return ()
_shiftDownLines tac (x:xs) shift = do
_shiftDownLines tac xs shift
TACU.moveChars tac x (0,shift)
deselect :: TAC.TextAreaContent -> IO TAC.Position
deselect tac = do
selectedPositions <- TAC.getSelectedPositons tac
updateCells tac selectedPositions False