{-# Language TemplateHaskell, BangPatterns #-}
module Client.State.EditBox.Content
(
Content
, above
, below
, singleLine
, noContent
, shift
, toStrings
, fromStrings
, Line(..)
, HasLine(..)
, endLine
, left
, right
, leftWord
, rightWord
, jumpLeft
, jumpRight
, delete
, backspace
, insertPastedString
, insertString
, insertChar
, toggle
, digraph
) where
import Control.Lens hiding ((<|), below)
import Control.Monad (guard)
import Data.Char (isAlphaNum)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Digraphs (lookupDigraph)
data Line = Line
{ _pos :: !Int
, _text :: !String
}
deriving (Read, Show)
makeClassy ''Line
emptyLine :: Line
emptyLine = Line 0 ""
beginLine :: String -> Line
beginLine = Line 0
endLine :: String -> Line
endLine s = Line (length s) s
data Content = Content
{ _above :: ![String]
, _currentLine :: !Line
, _below :: ![String]
}
deriving (Read, Show)
makeLenses ''Content
instance HasLine Content where
line = currentLine
noContent :: Content
noContent = Content [] emptyLine []
singleLine :: Line -> Content
singleLine l = Content [] l []
shift :: Content -> (String, Content)
shift (Content [] l []) = (view text l, noContent)
shift (Content a@(_:_) l b) = (last a, Content (init a) l b)
shift (Content [] l (b:bs)) = (view text l, Content [] (beginLine b) bs)
jumpLeft :: Content -> Content
jumpLeft c
| view pos c == 0 = maybe c begin1 (backwardLine c)
| otherwise = begin1 c
where
begin1 = set pos 0
jumpRight :: Content -> Content
jumpRight c
| view pos c == len = maybe c end1 (forwardLine c)
| otherwise = set pos len c
where
len = views text length c
end1 l = set pos (views text length l) l
left :: Content -> Content
left c =
case compare (view pos c) 0 of
GT -> (pos -~ 1) c
EQ | Just c' <- backwardLine c -> c'
_ -> c
right :: Content -> Content
right c =
let Line n s = view line c in
case compare n (length s) of
LT -> (pos +~ 1) c
EQ | Just c' <- forwardLine c -> c'
_ -> c
leftWord :: Content -> Content
leftWord c
| n == 0 = maybe c leftWord (backwardLine c)
| otherwise = set pos search c
where
Line n txt = view line c
search = maybe 0 fst
$ find (not . isAlphaNum . snd)
$ dropWhile (not . isAlphaNum . snd)
$ reverse
$ take n
$ zip [1..] txt
rightWord :: Content -> Content
rightWord c
| n == txtLen = maybe c rightWord (forwardLine c)
| otherwise = set pos search c
where
Line n txt = view line c
txtLen = length txt
search = maybe txtLen fst
$ find (not . isAlphaNum . snd)
$ dropWhile (not . isAlphaNum . snd)
$ drop n
$ zip [0..] txt
backspace :: Content -> Content
backspace c
| n == 0
= case view above c of
[] -> c
a:as -> set above as
. set line (Line (length a) (a ++ s))
$ c
| (preS, postS) <- splitAt (n-1) s
= set line (Line (n-1) (preS ++ drop 1 postS)) c
where
Line n s = view line c
delete :: Content -> Content
delete c =
let Line n s = view line c in
case splitAt n s of
(preS, _:postS) -> set text (preS ++ postS) c
_ -> case view below c of
[] -> c
b:bs -> set below bs
. set text (s ++ b)
$ c
insertChar :: Char -> Content -> Content
insertChar '\n' c =
let Line n txt = view line c in
case splitAt n txt of
(preS, postS) -> over above (preS :)
$ set line (beginLine postS) c
insertChar ins c = over line aux c
where
aux (Line n txt) =
case splitAt n txt of
(preS, postS) -> Line (n+1) (preS ++ ins : postS)
insertPastedString :: String -> Content -> Content
insertPastedString paste c = insertString (foldr scrub "" paste) c
where
cursorAtEnd = null (view below c)
&& length (view text c) == view pos c
scrub '\r' xs = xs
scrub '\n' xs@('\n':_) = xs
scrub '\n' "" | cursorAtEnd = ""
scrub x xs = x : xs
insertString :: String -> Content -> Content
insertString ins c =
case push (view above c) (preS ++ l) ls of
(newAbove, newLine) -> set above newAbove
$ set line newLine c
where
l:ls = lines (ins ++ "\n")
Line n txt = view line c
(preS, postS) = splitAt n txt
push stk x [] = (stk, Line (length x) (x ++ postS))
push stk x (y:ys) = push (x:stk) y ys
forwardLine :: Content -> Maybe Content
forwardLine c =
case view below c of
[] -> Nothing
b:bs -> Just
$! over above (view text c :)
$ set below bs
$ set line (beginLine b) c
backwardLine :: Content -> Maybe Content
backwardLine c =
case view above c of
[] -> Nothing
a:as -> Just
$! over below (view text c :)
$ set above as
$ set line (endLine a) c
toggle :: Content -> Content
toggle !c
| p < 1 = c
| n < 2 = c
| n == p = over text (swapAt (p-2)) c
| otherwise = set pos (p+1)
$ over text (swapAt (p-1)) c
where
p = view pos c
n = views text length c
swapAt 0 (x:y:z) = y:x:z
swapAt i (x:xs) = x:swapAt (i-1) xs
swapAt _ _ = error "toggle: PANIC! Invalid argument"
digraph :: Content -> Maybe Content
digraph !c =
do let Line n txt = view line c
guard (2 <= n)
let (pfx,x:y:sfx) = splitAt (n - 2) txt
d <- lookupDigraph x y
let line' = Line (n-1) (pfx++d:sfx)
Just $! set line line' c
fromStrings :: NonEmpty String -> Content
fromStrings (x :| xs) = Content xs (endLine x) []
toStrings :: Content -> NonEmpty String
toStrings c = foldl (flip (<|)) (view text c :| view above c) (view below c)