{- |
This module contains the various datatypes which model the state of the line; that is, the characters displayed and the position of the cursor.
-}
module System.Console.Haskeline.LineState(
                    -- * Graphemes
                    Grapheme(),
                    baseChar,
                    stringToGraphemes,
                    graphemesToString,
                    modifyBaseChar,
                    mapBaseChars,
                    -- * Line State class
                    LineState(..),
                    Prefix,
                    -- ** Convenience functions for the drawing backends
                    LineChars,
                    lineChars,
                    lengthToEnd,
                    -- ** Supplementary classes
                    Result(..),
                    Save(..),
                    listSave,
                    listRestore,
                    Move(..),
                    -- * Instances
                    -- ** InsertMode
                    InsertMode(..),
                    emptyIM,
                    insertChar,
                    insertString,
                    replaceCharIM,
                    insertGraphemes,
                    deleteNext,
                    deletePrev,
                    skipLeft,
                    skipRight,
                    transposeChars,
                    -- *** Moving to word boundaries
                    goRightUntil,
                    goLeftUntil,
                    atStart,
                    atEnd,
                    beforeChar,
                    afterChar,
                    overChar,
                    -- ** CommandMode
                    CommandMode(..),
                    deleteChar,
                    replaceChar,
                    pasteGraphemesBefore,
                    pasteGraphemesAfter,
                    -- *** Transitioning between modes
                    enterCommandMode,
                    enterCommandModeRight,
                    insertFromCommandMode,
                    appendFromCommandMode,
                    withCommandMode,
                    -- ** ArgMode
                    ArgMode(..),
                    startArg,
                    addNum,
                    applyArg,
                    applyCmdArg,
                    -- ** Other line state types
                    Message(..),
                    Password(..),
                    addPasswordChar,
                    deletePasswordChar,
                    ) where

import Data.Char

-- | A 'Grapheme' is a fundamental unit of display for the UI.  Several characters in sequence
-- can represent one grapheme; for example, an @a@ followed by the diacritic @\'\\768\'@ should
-- be treated as one unit.
data Grapheme = Grapheme {gBaseChar :: Char,
                            combiningChars :: [Char]}
                    deriving Eq

instance Show Grapheme where
    show g = show (gBaseChar g : combiningChars g)

baseChar :: Grapheme -> Char
baseChar = gBaseChar

modifyBaseChar :: (Char -> Char) -> Grapheme -> Grapheme
modifyBaseChar f g = g {gBaseChar = f (gBaseChar g)}

mapBaseChars :: (Char -> Char) -> [Grapheme] -> [Grapheme]
mapBaseChars f = map (modifyBaseChar f)

-- | Create a 'Grapheme' from a single base character.
--
-- NOTE: Careful, don't use outside this module; and inside, make sure this is only
-- ever called on non-combining characters.
baseGrapheme :: Char -> Grapheme
baseGrapheme c = Grapheme {gBaseChar = c, combiningChars = []}

-- | Add a combining character to the given 'Grapheme'.
addCombiner :: Grapheme -> Char -> Grapheme
addCombiner g c = g {combiningChars = combiningChars g ++ [c]}

isCombiningChar :: Char -> Bool
isCombiningChar c = generalCategory c == NonSpacingMark

-- | Converts a string into a sequence of graphemes.
--
-- NOTE: Drops any initial, unattached combining characters.
stringToGraphemes :: String -> [Grapheme]
stringToGraphemes = mkString . dropWhile isCombiningChar
    where
        mkString [] = []
        -- Minor hack: "\ESC...\STX" or "\SOH\ESC...\STX", where "\ESC..." is some
        -- control sequence (e.g., ANSI colors), is represented as a grapheme
        -- of zero length with '\ESC' as the base character.
        -- Note that this won't round-trip correctly with graphemesToString.
        -- In practice, however, that's fine since control characters can only occur
        -- in the prompt.
        mkString ('\SOH':cs) = stringToGraphemes cs
        mkString ('\ESC':cs) | (ctrl,'\STX':rest) <- break (=='\STX') cs
                    = Grapheme '\ESC' ctrl : stringToGraphemes rest
        mkString (c:cs) = Grapheme c (takeWhile isCombiningChar cs)
                                : mkString (dropWhile isCombiningChar cs)

graphemesToString :: [Grapheme] -> String
graphemesToString = concatMap (\g -> (baseChar g : combiningChars g))

-- | This class abstracts away the internal representations of the line state,
-- for use by the drawing actions.  Line state is generally stored in a zipper format.
class LineState s where
    beforeCursor :: Prefix -- ^ The input prefix.
                    -> s -- ^ The current line state.
                    -> [Grapheme] -- ^ The text to the left of the cursor
                                  -- (including the prefix).
    afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor.

type Prefix = [Grapheme]

-- | The characters in the line (with the cursor in the middle).  NOT in a zippered format;
-- both lists are in the order left->right that appears on the screen.
type LineChars = ([Grapheme],[Grapheme])

-- | Accessor function for the various backends.
lineChars :: LineState s => Prefix -> s -> LineChars
lineChars prefix s = (beforeCursor prefix s, afterCursor s)

-- | Compute the number of characters under and to the right of the cursor.
lengthToEnd :: LineChars -> Int
lengthToEnd = length . snd

class LineState s => Result s where
    toResult :: s -> String

class LineState s => Save s where
    save :: s -> InsertMode
    restore :: InsertMode -> s

listSave :: Save s => s -> [Grapheme]
listSave s = case save s of IMode xs ys -> reverse xs ++ ys

listRestore :: Save s => [Grapheme] -> s
listRestore xs = restore $ IMode (reverse xs) []

class Move s where
    goLeft, goRight, moveToStart, moveToEnd :: s -> s

-- | The standard line state representation; considers the cursor to be located
-- between two characters.  The first list is reversed.
data InsertMode = IMode [Grapheme] [Grapheme]
                    deriving (Show, Eq)

instance LineState InsertMode where
    beforeCursor prefix (IMode xs _) = prefix ++ reverse xs
    afterCursor (IMode _ ys) = ys

instance Result InsertMode where
    toResult (IMode xs ys) = graphemesToString $ reverse xs ++ ys

instance Save InsertMode where
    save = id
    restore = id

instance Move InsertMode where
    goLeft im@(IMode [] _) = im
    goLeft (IMode (x:xs) ys) = IMode xs (x:ys)

    goRight im@(IMode _ []) = im
    goRight (IMode ys (x:xs)) = IMode (x:ys) xs

    moveToStart (IMode xs ys) = IMode [] (reverse xs ++ ys)
    moveToEnd (IMode xs ys) = IMode (reverse ys ++ xs) []

emptyIM :: InsertMode
emptyIM = IMode [] []

-- | Insert one character, which may be combining, to the left of the cursor.
--  
insertChar :: Char -> InsertMode -> InsertMode
insertChar c im@(IMode xs ys)
    | isCombiningChar c = case xs of
                            []   -> im -- drop a combining character if it
                                       -- appears at the start of the line.
                            z:zs -> IMode (addCombiner z c : zs) ys
    | otherwise         = IMode (baseGrapheme c : xs) ys

-- | Insert a sequence of characters to the left of the cursor. 
insertString :: String -> InsertMode -> InsertMode
insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys

deleteNext, deletePrev :: InsertMode -> InsertMode
deleteNext im@(IMode _ []) = im
deleteNext (IMode xs (_:ys)) = IMode xs ys

deletePrev im@(IMode [] _) = im
deletePrev (IMode (_:xs) ys) = IMode xs ys

skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode
skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs
                           in IMode zs (reverse ws ++ ys)
skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys
                            in IMode (reverse ws ++ xs) zs

transposeChars :: InsertMode -> InsertMode
transposeChars (IMode (x:xs) (y:ys)) = IMode (x:y:xs) ys
transposeChars (IMode (y:x:xs) []) = IMode (x:y:xs) []
transposeChars im = im

insertGraphemes :: [Grapheme] -> InsertMode -> InsertMode
insertGraphemes s (IMode xs ys) = IMode (reverse s ++ xs) ys

-- For the 'R' command.
replaceCharIM :: Char -> InsertMode -> InsertMode
replaceCharIM c im
    | isCombiningChar c = case im of
                    IMode [] [] -> im
                    IMode [] (y:ys) -> IMode [] (addCombiner y c:ys)
                    IMode (x:xs) ys -> IMode (addCombiner x c:xs) ys
    | otherwise = let g = baseGrapheme c
                  in case im of
                    IMode xs [] -> IMode (g:xs) []
                    IMode xs (_:ys) -> IMode (g:xs) ys


-- | Used by vi mode.  Considers the cursor to be located over some specific character.
-- The first list is reversed.
data CommandMode = CMode [Grapheme] Grapheme [Grapheme] | CEmpty
                    deriving Show

instance LineState CommandMode where
    beforeCursor prefix CEmpty = prefix
    beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs
    afterCursor CEmpty = []
    afterCursor (CMode _ c ys) = c:ys

instance Result CommandMode where
    toResult CEmpty = ""
    toResult (CMode xs c ys) = graphemesToString $ reverse xs ++ (c:ys)

instance Save CommandMode where
    save = insertFromCommandMode
    restore = enterCommandModeRight

instance Move CommandMode where
    goLeft (CMode (x:xs) c ys) = CMode xs x (c:ys)
    goLeft cm = cm

    goRight (CMode xs c (y:ys)) = CMode (c:xs) y ys
    goRight cm = cm

    moveToStart (CMode xs c ys) = let zs = reverse xs ++ (c:ys) in CMode [] (head zs) (tail zs)
    moveToStart CEmpty = CEmpty

    moveToEnd (CMode xs c ys) = let zs = reverse ys ++ (c:xs) in CMode (tail zs) (head zs) []
    moveToEnd CEmpty = CEmpty

deleteChar :: CommandMode -> CommandMode
deleteChar (CMode xs _ (y:ys)) = CMode xs y ys
deleteChar (CMode (x:xs) _ []) = CMode xs x []
deleteChar _ = CEmpty

replaceChar :: Char -> CommandMode -> CommandMode
replaceChar c (CMode xs d ys)
    | not (isCombiningChar c)   = CMode xs (baseGrapheme c) ys
    | otherwise                 = CMode xs (addCombiner d c) ys
replaceChar _ CEmpty = CEmpty

pasteGraphemesBefore, pasteGraphemesAfter :: [Grapheme] -> CommandMode -> CommandMode
pasteGraphemesBefore [] = id
pasteGraphemesBefore s = enterCommandMode . insertGraphemes s . insertFromCommandMode

pasteGraphemesAfter [] = id
pasteGraphemesAfter s = enterCommandMode . insertGraphemes s . appendFromCommandMode

------------------------
-- Transitioning between modes

enterCommandMode, enterCommandModeRight :: InsertMode -> CommandMode
enterCommandMode (IMode (x:xs) ys) = CMode xs x ys
enterCommandMode (IMode [] (y:ys)) = CMode [] y ys
enterCommandMode _ = CEmpty

enterCommandModeRight (IMode xs (y:ys)) = CMode xs y ys
enterCommandModeRight (IMode (x:xs) []) = CMode xs x []
enterCommandModeRight _ = CEmpty


insertFromCommandMode, appendFromCommandMode :: CommandMode -> InsertMode

insertFromCommandMode CEmpty = emptyIM
insertFromCommandMode (CMode xs c ys) = IMode xs (c:ys)

appendFromCommandMode CEmpty = emptyIM
appendFromCommandMode (CMode xs c ys) = IMode (c:xs) ys

withCommandMode :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode
withCommandMode f = enterCommandModeRight . f . insertFromCommandMode

----------------------
-- Supplementary modes

-- | Used for commands which take an integer argument.
data ArgMode s = ArgMode {arg :: Int, argState :: s}

instance Functor ArgMode where
    fmap f am = am {argState = f (argState am)}

instance LineState s => LineState (ArgMode s) where
    beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") "
                             in beforeCursor pre (argState am)
    afterCursor = afterCursor . argState

instance Result s => Result (ArgMode s) where
    toResult = toResult . argState

instance Save s => Save (ArgMode s) where
    save = save . argState
    restore = startArg 0 . restore

startArg :: Int -> s -> ArgMode s
startArg = ArgMode

addNum :: Int -> ArgMode s -> ArgMode s
addNum n am
    | arg am >= 1000 = am -- shouldn't ever need more than 4 digits
    | otherwise = am {arg = arg am * 10 + n}

-- todo: negatives
applyArg :: (s -> s) -> ArgMode s -> s
applyArg f am = repeatN (arg am) f (argState am)

repeatN :: Int -> (a -> a) -> a -> a
repeatN n f | n <= 1 = f
          | otherwise = f . repeatN (n-1) f

applyCmdArg :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> CommandMode
applyCmdArg f am = withCommandMode (repeatN (arg am) f) (argState am)

---------------
newtype Message = Message {messageText :: String}

instance LineState Message where
    beforeCursor _ = stringToGraphemes . messageText
    afterCursor _ = []

----------------

data Password = Password {passwordState :: [Char], -- ^ reversed
                          passwordChar :: Maybe Char}

instance LineState Password where
    beforeCursor prefix p
        = prefix ++ (stringToGraphemes
                      $ case passwordChar p of
                        Nothing -> []
                        Just c -> replicate (length $ passwordState p) c)
    afterCursor _ = []

instance Result Password where
    toResult = reverse . passwordState

addPasswordChar :: Char -> Password -> Password
addPasswordChar c p = p {passwordState = c : passwordState p}

deletePasswordChar :: Password -> Password
deletePasswordChar (Password (_:cs) m) = Password cs m
deletePasswordChar p = p

-----------------
atStart, atEnd :: (Char -> Bool) -> InsertMode -> Bool
atStart f (IMode (x:_) (y:_)) = not (f (baseChar x)) && f (baseChar y)
atStart _ _ = False

atEnd f (IMode _ (y1:y2:_)) = f (baseChar y1) && not (f (baseChar y2))
atEnd _ _ = False

overChar, beforeChar, afterChar :: (Char -> Bool) -> InsertMode -> Bool
overChar f (IMode _ (y:_)) = f (baseChar y)
overChar _ _ = False

beforeChar f (IMode _ (_:y:_)) = f (baseChar y)
beforeChar _ _ = False

afterChar f (IMode (x:_) _) = f (baseChar x)
afterChar _ _ = False

goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode
goRightUntil f = loop . goRight
    where
        loop im@(IMode _ ys) | null ys || f im  = im
                             | otherwise = loop (goRight im)
goLeftUntil f = loop . goLeft
    where
        loop im@(IMode xs _)   | null xs || f im = im
                            | otherwise = loop (goLeft im)