module Yavie.EditorCore (

  EditorC

, moveToLine
, moveInline
, moveToChar

, resetYank

, deleteToLine
, deleteInline
, deleteToChar

, setMonitorY

, insertChar
, insertNL

, inInsertMode
, outInsertMode
, isInsertMode

, yankToLine
, yankLinesCursTo
, yankLinesNum
, yankLinesFromTo

, getCursX
, getCursY

, saveToEditorCore
, resaveToEditorCore

, moveCursorForCursorIn
, scrollForCursorIn

, modifyContainer
, getsContainer
, getsContainerWithMonitorY
, getCursorYInMonitor

, getFileName

, linesForDisplay

, resizeMonitor
, addEmptyIfNoLine

, concatTwoLines

, saveToHistory
, undo
, redo
, flipCase

, pasteYanked
, pasteYankedAfter

, getBufferContents
, lineNum

, isModified
, resetModified

, resetStatus
, setStatus
, addStatus
, bsStatus

, setToCursY

, resetIOAction
, setIOAction
, runIOAction

, saveToFileC
, saveToTmpFile

) where

import Yavie.Tools         ( lastIndex, inFromMToN, intoNToM, zeroToN,
                             opfs, takeXY, dropXY, reverseXY, findIndexXY )
import Data.Maybe    ( fromMaybe )
import Data.Char     ( isLower, isUpper, toLower, toUpper )
import Control.Arrow ( first )
import System.FilePath

data EditorC c = Editor {

  fileName      :: String ,
  buffer        :: [ String ] ,
  status        :: String ,
  cursXX        :: Int ,
  cursX         :: Int ,
  cursY         :: Int ,
  monWidth      :: Int ,
  monHeight     :: Int ,
  monY          :: Int ,

  inlineYank    :: Bool ,
  yankedLines   :: [ String ] ,
  yankedString  :: String ,

  insertMode    :: Bool ,

  bufferHistory :: [ [ String ] ] ,
  redoHistory   :: [ [ String ] ] ,
  udHistCur     :: [ ( Int, Int ) ] ,
  crHistCur     :: ( Int, Int ) ,
  rdHistCur     :: [ ( Int, Int ) ] ,

  modified      :: Int ,

  container     :: c ,

  exCommand     :: EditorC c -> IO ( EditorC c ) ,

  ioAction      :: EditorC c -> IO ( EditorC c )

 }

type ToLineMoveRule = Int -> Int -> Int -> Int -> Int
type InlineMoveRule = String -> Int -> Maybe Int
type ToCharMoveRule = Char -> Char -> Bool
type BufferFun      = [ String ] -> Int -> Int -> ( Int, Int )

intoLine :: EditorC c -> EditorC c
intoLine ed@Editor { cursX = cx } =
  ed { cursX = inFromMToN ( minCurX ed ) ( maxCurX ed ) cx }

setCursY :: Int -> EditorC c -> EditorC c
setCursY cy ed@Editor { buffer = buf, cursXX = cx } = scrollForCursorIn $
  intoLine ed { cursY = inFromMToN 0 ( lastIndex buf ) cy, cursX = cx }

setCursPos :: Int -> Int -> EditorC c -> EditorC c
setCursPos cx cy ed =
  intoLine ed { cursX = cx, cursXX = cx,
                cursY = inFromMToN 0 ( lastIndex $ buffer ed ) cy }

toEditorFun :: BufferFun -> EditorC c -> EditorC c
toEditorFun f ed@Editor { buffer = buf, cursX = cx, cursY = cy } =
  uncurry setCursPos ( f buf cx cy ) ed

moveToLine :: ToLineMoveRule -> EditorC c -> EditorC c
moveToLine f ed =
  setCursY ( f ( numOfLines ed ) ( monHeight ed ) ( monY ed ) ( cursY ed ) ) ed

moveInline :: Bool -> Bool -> Bool -> InlineMoveRule -> EditorC c -> EditorC c
moveInline next back wrap = toEditorFun . getInline next back wrap

moveToChar ::  Bool -> Bool -> ToCharMoveRule -> EditorC c -> EditorC c
moveToChar next back = toEditorFun . getToChar next back

getInline :: Bool -> Bool -> Bool -> InlineMoveRule -> BufferFun
getInline next back wrap mv buf cx cy = fromMaybe ( cx, cy ) $ gi wrap ncx cy
  where
  ncx        = if next then goNext cx             else cx
  goNext     = if back then (+ (-1))              else (+ 1)
  wrapped    = if back then lastIndex buf         else 0
  lineTop y  = if back then lastIndex $ buf !! y  else 0
  needWrap y = if back then y <= 0 else y >= lastIndex buf
  gi w x y   = case ( mv ( buf !! y ) x, mny ) of
                    ( Just nx, _       ) -> Just ( nx, y )
                    ( _      , Just ny ) -> gi nw ( lineTop ny ) ny
                    _                    -> Nothing
    where
    mny         = case ( needWrap y, w ) of
                       ( False, _    ) -> Just $ goNext y
                       ( _    , True ) -> Just   wrapped
                       _               -> Nothing
    nw          = w && not ( needWrap y )

getToChar ::
  Bool -> Bool -> ToCharMoveRule -> [ String ] -> Int -> Int -> ( Int, Int )
getToChar next back test buf =
  curry $ renext . bufPos . uncurry ( gtc test nbuf ) . nbufPos . getnext
  where
  getnext   = if next then uncurry nextPos         else id
  renext    = if next then uncurry beforePos       else id
  nextPos   = if back then getBackOverlineMore buf else getForwardOverline buf
  beforePos = if back then getForwardOverline  buf else getBackOverline    buf
  nbuf      = if back then map ('\n':) buf         else map (++"\n") buf
  nbufPos   = if back then first (+    1)          else id
  bufPos    = if back then first (+ (- 1))         else id
  gtc p lns x y = newPos
    where
    newPos@( _, ny ) = ( baseX, y ) `addPos` dffPos
    dffPos@( _, dy ) = fromMaybe ( 0, 0 ) $
                         findIndexXY ( p $ lns !! y !! x ) field
    field            = if back then reverseXY $ takeXY ( x + 1 ) y lns
                               else             dropXY x         y lns
    baseX            = if dy == 0 then x else if back then lastX else 0
    lastX            = lastIndex $ lns !! ny
    addPos           = if back then (-) `opfs` (-) else (+) `opfs` (+)

resetYank :: EditorC c -> EditorC c
resetYank ed = ed { inlineYank = False, yankedLines = [ ], yankedString = "" }

deleteToPos :: Int -> Int -> EditorC c -> EditorC c
deleteToPos nx ny ed@Editor { buffer = buf, cursX = cx, cursY = cy } =
  ed { buffer       = deleted,
       inlineYank   = True,
       yankedString = yankedString ed ++ yanked,
       cursY = nny, cursX = nnx }
  where
  ( deleted, yanked ) = getDeleteToPos cx cy nx ny buf
  ( nny, nnx )        = min ( cy, cx ) ( ny, nx )

getDeleteToPos :: Int -> Int -> Int -> Int -> [ String ]
                                           -> ( [ String ], String )
getDeleteToPos xmin ymin xmax ymax buf
  | ( ymin, xmin ) <= ( ymax, xmax ) = ( deleted, yanked )
  | otherwise                        = getDeleteToPos xmax ymax xmin ymin buf
  where
  deleted = take ymin buf ++ [ take xmin minLn ++ drop xmax maxLn ]
                          ++ drop ( ymax + 1 ) buf
  yanked
    | ymin == ymax = drop xmin $ take xmax minLn
    | otherwise    = init $ unlines $ drop xmin minLn : drop ( ymin + 2 ) ( take ymax buf )
                                      ++ [ take xmax maxLn ]
  minLn = buf !! ymin
  maxLn = buf !! ymax

deleteToLine :: ToLineMoveRule -> EditorC c -> EditorC c
deleteToLine f ed =
  let ny = f ( length $ buffer ed ) ( monHeight ed ) ( monY ed ) ( cursY ed )
   in deleteLinesFromTo ( cursY ed ) ny ed

deleteLinesFromTo :: Int -> Int -> EditorC c -> EditorC c
deleteLinesFromTo y1 y2 ed@Editor { buffer = buf }
  | y1 <= y2  = setCursY y1
                  ed { buffer      = take y1 buf ++ drop ( y2 + 1 ) buf ,
                       yankedLines = drop y1 $      take ( y2 + 1 ) buf ,
                       inlineYank  = False }
  | otherwise = deleteLinesFromTo y2 y1 ed

deleteInline :: Bool -> Bool -> InlineMoveRule -> EditorC c -> EditorC c
deleteInline next back mv ed@Editor { buffer = buf, cursX = cx, cursY = cy } =
  uncurry deleteToPos ( getInline next back False mv buf cx cy ) ed

deleteToChar :: Bool -> Bool -> ToCharMoveRule -> EditorC c -> EditorC c
deleteToChar next backward p
  ed@Editor { buffer = buf, cursX = cx, cursY = cy } = deleteToPos nx ny ed
  where
  cx_        = if next
                  then if backward then cx - 1
                                   else cx + 1
                  else cx
  ( nx_, ny ) = getToChar False backward p buf cx_ cy
  nx          = if next
                   then if backward then nx_ + 1
                                    else nx_ - 1
                   else nx_

setMonitorY :: ( Int -> Int -> Int -> Int ) -> EditorC c -> EditorC c
setMonitorY f ed@Editor { buffer = buf, cursY = cy, monY = my, monHeight = mh } =
  let nmy = ( if length buf > mh then zeroToN ( length buf - mh ) else const 0 ) $
              f mh cy my
   in moveCursorForCursorIn ed { monY = nmy }

saveToEditorCore :: c -> Int -> Int -> String -> String -> EditorC c
saveToEditorCore c w h fn cnt = Editor {

  buffer        = if null cnt then [ "" ] else lines cnt ,
  bufferHistory = [ ] ,
  udHistCur     = [ ] ,
  crHistCur     = ( 0, 0 ) ,
  redoHistory   = [ ] ,
  rdHistCur     = [ ] ,
  fileName      = fn ,
  status        = "" ,
  cursXX        = 0 ,
  cursX         = 0 ,
  cursY         = 0 ,
  monWidth      = w ,
  monHeight     = h - 1 ,
  monY          = 0 ,

  inlineYank    = False ,
  yankedLines   = [ ] ,
  yankedString  = "" ,

  insertMode    = False ,

  modified      = 0 ,

  container     = c ,

  exCommand     = return ,
  ioAction      = return

 }

setIOAction ::
  ( EditorC c -> IO ( EditorC c ) ) -> EditorC c -> EditorC c
setIOAction  io ed = ed { ioAction = io }

runIOAction :: EditorC c -> IO ( EditorC c )
runIOAction  ed = fmap resetIOAction $ ioAction ed ed

resetIOAction :: EditorC c -> EditorC c
resetIOAction  ed = ed { ioAction = return }

saveToTmpFile :: EditorC c -> IO ( EditorC c )
saveToTmpFile ed = do
  let lns = lineNum ed
      fn  = getFileName ed
  putStr $ take ( lns - lns ) "dummy"
  writeFile ( takeDirectory fn ++ "/.yavie." ++ takeFileName  fn ) ( getBufferContents ed )
  return $ setStatus "written tmp" ed

saveToFileC :: EditorC c -> IO ( EditorC c )
saveToFileC ed =
          do let lns = lineNum ed
             putStr $ take ( lns - lns ) "dummy"
             writeFile ( getFileName ed ) ( getBufferContents ed )
             return $ setStatus "written" $ resetModified ed

resaveToEditorCore :: String -> String -> EditorC c -> EditorC c
resaveToEditorCore fn cnt ed = ed {

  buffer       = if null cnt then [ "" ] else lines cnt ,
  fileName     = fn ,

  bufferHistory = [ ] ,
  udHistCur     = [ ] ,
  crHistCur     = ( 0, 0 ) ,
  redoHistory   = [ ] ,
  rdHistCur     = [ ] ,

  status       = "new file " ++ fn ,
  cursXX       = if fileName ed == fn then cursX  ed else 0 ,
  cursX        = if fileName ed == fn then cursXX ed else 0 ,
  cursY        = if fileName ed == fn then cursY  ed else 0 ,

  monY         = if fileName ed == fn then monY   ed else 0 ,

  modified     = 0

 }

getFileName :: EditorC c -> String
getFileName = fileName

getBackOverline, getBackOverlineMore, getForwardOverline ::
  [ String ] -> Int -> Int -> ( Int, Int )

getBackOverlineMore _   (-1) 0  = ( -1, 0 )
getBackOverlineMore _   0    0  = ( -1, 0 )
getBackOverlineMore buf (-1) cy = let nx = length $ buf !! ( cy - 1 )
                                   in ( nx, cy - 1 )
getBackOverlineMore _   cx   cy = ( cx - 1, cy )

getBackOverline _   (-1) 0  = ( -1, 0 )
getBackOverline _   0    0  = ( -1, 0 )
getBackOverline buf 0    cy = let nx = length $ buf !! ( cy - 1 )
                               in ( nx, cy - 1 )
getBackOverline _   cx   cy = ( cx - 1, cy )

getForwardOverline buf cx cy
  | cy == length buf && cx == length ( buf !! cy ) = ( cx    , cy     )
  | cx == length ( buf !! cy )                     = ( 0     , cy + 1 )
  | otherwise                                      = ( cx + 1, cy     )

modifyContainer :: ( c -> c ) -> EditorC c -> EditorC c
modifyContainer f ed@Editor { container = c } = ed { container = f c }

getsContainer :: ( c -> a ) -> EditorC c -> a
getsContainer f = f . container

getsContainerWithMonitorY :: ( c -> a ) -> ( a -> Int -> b ) -> EditorC c -> b
getsContainerWithMonitorY f op Editor { monY = my, container = c } = 
  op ( f c ) my

getCursorYInMonitor :: EditorC c -> Int
getCursorYInMonitor Editor { cursY = cy, monY = my } = cy - my + 1

scrollForCursorIn :: EditorC c -> EditorC c
scrollForCursorIn = setMonitorY cursorIn
  where cursorIn mh cy = intoNToM ( cy - mh + 1 ) cy

moveCursorForCursorIn :: EditorC c -> EditorC c
moveCursorForCursorIn ed@Editor { cursY = cy, monHeight = mh, monY = my }
  | cy < my          = setCursY my ed
  | cy > my + mh - 1 = setCursY ( my + mh - 1 ) ed
  | otherwise        = ed

linesForDisplay :: EditorC c -> ( ( Int, Int ), [ String ] )
linesForDisplay Editor
  { buffer = buf, status = stat, cursX = cx, cursY = cy,
    monHeight = mh, monY = my, monWidth = mw } =
  ( ( cx, cy - my ),
    addToNA mh "" ( take mh ( drop my buf ) ) ++ [ statLn ] )
  where
  prcnt  = if length buf > mh then my * 100 `div` ( length buf - mh ) else 100
  statLn = stat ++ addToNB ( mw - length stat - 16 ) ' '
                           ( show ( cy + 1 ) ++ "," ++ show ( cx + 1 ) )
                ++ addToNB 16 ' ' ( show prcnt ++ "%" )
  addToNB n x xs = replicate ( n - length xs ) x ++ xs
  addToNA n x xs = xs ++ replicate ( n - length xs ) x

resizeMonitor :: Int -> Int -> EditorC c -> EditorC c
resizeMonitor w h ed = ed { monWidth = w, monHeight = h }

addEmptyIfNoLine :: EditorC c -> EditorC c
addEmptyIfNoLine ed@Editor { buffer = [ ] } = ed { buffer = [ "" ] }
addEmptyIfNoLine ed = ed

concatTwoLines :: EditorC c -> EditorC c
concatTwoLines ed@Editor { buffer = buf, cursY = cy }
  = ed { buffer   = take cy buf ++
                    [ buf !! cy ++ buf !! ( cy + 1 ) ] ++
                    drop ( cy + 2 ) buf }

insertChar :: Char -> EditorC c -> EditorC c
insertChar ch ed@Editor { buffer = buf, cursX = cx, cursY = cy }
  = let thisLn = buf !! cy
        ned    = ed { buffer   = take cy buf ++
                                 [ take cx thisLn ++ [ ch ] ++ drop cx thisLn ] ++
                                 drop ( cy + 1 ) buf ,
                      cursX    = if cx < 0 then 1 else cx + 1 ,
                      cursXX   = cursX ned }
     in ned

insertNL :: EditorC c -> EditorC c
insertNL ed@Editor { buffer = buf, cursX = cx, cursY = cy }
  = let thisLn = buf !! cy
        ned    = ed { buffer   = take cy buf ++
                                 [ take cx thisLn, drop cx thisLn ] ++
                                 drop ( cy + 1 ) buf ,
                      cursX    = 0 ,
                      cursY    = cy + 1 ,
                      cursXX   = cursX ned }
     in scrollForCursorIn ned

yankToLine :: ToLineMoveRule -> EditorC c -> EditorC c
yankToLine = error "yet"

yankLinesCursTo :: Int -> EditorC c -> EditorC c
yankLinesCursTo ny ed@Editor { cursY = cy }
  = yankLinesFromTo cy ny ed

yankLinesNum :: Int -> EditorC c -> EditorC c
yankLinesNum ln ed@Editor { cursY = cy }
  = yankLinesCursTo ( cy + ln - 1 ) ed

yankLinesFromTo :: Int -> Int -> EditorC c -> EditorC c
yankLinesFromTo y1 y2 ed@Editor { buffer = buf }
  | y1 >= y2  = ed { yankedLines = take ( y1 - y2 + 1 ) $ drop y2 buf,
                     inlineYank = False }
  | otherwise = ed { yankedLines = take ( y2 - y1 + 1 ) $ drop y1 buf,
                     inlineYank = False }

saveToHistory :: EditorC c -> EditorC c
saveToHistory ed@Editor
  { buffer = buf, bufferHistory = bufHst,
    cursX = cx, cursY = cy, udHistCur = uhc, modified = m } =
  ed { bufferHistory = buf : bufHst, udHistCur = ( cx, cy ) : uhc ,
       redoHistory = [], rdHistCur = [],
       modified = m + 1 }

undo :: EditorC c -> EditorC c
undo ed@Editor
  { buffer = buf, bufferHistory = bufHst, redoHistory = rdHst ,
    udHistCur = uhc, rdHistCur = rhc, crHistCur = chc ,
    modified = m } =
  if not $ null bufHst
     then scrollForCursorIn $
          ed { buffer = head bufHst ,
               bufferHistory = tail bufHst ,
               redoHistory = buf : rdHst ,
               cursX = fst $ head uhc, cursY = snd $ head uhc ,
               crHistCur = head uhc,
               udHistCur = tail uhc, rdHistCur = chc : rhc ,
               modified = m - 1 }
     else ed

redo :: EditorC c -> EditorC c
redo ed@Editor
  { buffer = buf, bufferHistory = bufHst, redoHistory = rdHst ,
    udHistCur = uhc, rdHistCur = rhc, crHistCur = chc ,
    modified = m } =
  if not $ null rdHst
     then scrollForCursorIn $
          ed { buffer = head rdHst ,
               bufferHistory = buf : bufHst ,
               redoHistory = tail rdHst,
               cursX = fst chc, cursY = snd chc ,
               crHistCur = head rhc ,
               udHistCur = chc : uhc, rdHistCur = tail rhc ,
               modified = m + 1 }
     else ed

flipCase :: EditorC c -> EditorC c
flipCase ed@Editor { buffer = buf, cursX = cx, cursY = cy }
  = let thisLn = buf !! cy
     in ed { buffer =
              take cy buf ++
              [ take cx thisLn ++ [ fc ( thisLn !! cx ) ]
                               ++ drop ( cx + 1 ) thisLn ] ++
              drop ( cy + 1 ) buf }
  where
  fc c | isUpper c = toLower c
       | isLower c = toUpper c
       | otherwise = c

pasteYankedInline :: EditorC c -> EditorC c
pasteYankedInline ed@Editor { buffer = buf, cursY = cy, cursX = cx }
  = ed { buffer = nbuf }
  where
  thisLn = buf !! cy
  y      = lines_ $ yankedString ed
  nbuf   = case y of
                [ ]    -> error "yet"
                [ sy ] -> take cy buf ++ [ take cx thisLn ++ sy ++ drop cx thisLn ]
                                      ++ drop ( cy + 1 ) buf
                ( fy : ry ) -> take cy buf ++ [ take cx thisLn ++ fy ]
                                           ++ init ry
                                           ++ [ last ry ++ drop cx thisLn ]
                                           ++ drop ( cy + 1 ) buf

lines_ :: String -> [ String ]
lines_ = splitBy '\n'

splitBy :: Eq a => a -> [ a ] -> [ [ a ] ]
splitBy _ [ ] = [ ]
splitBy x xs  = takeWhile (/= x) xs : splitBy x ( tailIfX $ dropWhile (/= x) xs )
  where
  tailIfX ( y : ys ) | x == y = ys
  tailIfX ya                  = ya

pasteYankedInlineAfter :: EditorC c -> EditorC c
pasteYankedInlineAfter ed@Editor { buffer = buf, cursY = cy, cursX = cx }
  = let thisLn = buf !! cy
     in ed { buffer = take cy buf ++
                      [ take ( cx + 1 ) thisLn ++ y ++ drop ( cx + 1 ) thisLn ] ++
                      drop ( cy + 1 ) buf }
  where
  y = yankedString ed

getCursX, getCursY :: EditorC c -> Int
getCursX = cursX
getCursY = cursY

getBufferContents :: EditorC c -> String
getBufferContents Editor { buffer = buf } = unlines buf

lineNum :: EditorC c -> Int
lineNum = length . buffer

pasteYankedLine :: EditorC c -> EditorC c
pasteYankedLine ed@Editor { buffer = buf }
  = ed { buffer = take cy buf ++ y ++ drop cy buf }
  where
  cy = getCursY ed
  y = yankedLines ed

pasteYankedLineAfter :: EditorC c -> EditorC c
pasteYankedLineAfter ed@Editor { buffer = buf }
  = ed { buffer = take ( cy + 1 ) buf ++ y ++ drop ( cy + 1 ) buf }
  where
  cy = getCursY ed
  y = yankedLines ed

pasteYanked :: EditorC c -> EditorC c
pasteYanked ed =
  if inlineYank ed then pasteYankedInline ed
                   else pasteYankedLine ed

pasteYankedAfter :: EditorC c -> EditorC c
pasteYankedAfter ed =
  if inlineYank ed then pasteYankedInlineAfter  ed
                   else pasteYankedLineAfter ed

isModified :: EditorC c -> Bool
isModified = (0 /=) .  modified

resetModified :: EditorC c -> EditorC c
resetModified ed = ed { modified = 0 }

addStatus :: Char -> EditorC c -> EditorC c
addStatus ch ed@Editor { status = stat } = ed { status = stat ++ [ ch ] }

bsStatus :: EditorC c -> EditorC c
bsStatus ed@Editor { status = stat } = ed { status = init_ stat }

init_ :: [ a ] -> [ a ]
init_ [ ]   = [ ]
init_ [ x ] = [ x ]
init_ lst   = init lst

resetStatus :: EditorC c -> EditorC c
resetStatus ed = ed { status = "" }

setStatus :: String -> EditorC c -> EditorC c
setStatus str ed = ed { status = str }

setToCursY :: ( Int -> c -> c ) -> EditorC c -> EditorC c
setToCursY f ed@Editor { cursY = cy, container = c } =
  ed { container = f cy c }

inInsertMode, outInsertMode :: EditorC c -> EditorC c
inInsertMode  ed =            ed { insertMode = True  }
outInsertMode ed = intoLine $ ed { insertMode = False }
isInsertMode :: EditorC c -> Bool
isInsertMode     = insertMode

maxCurX :: EditorC c -> Int
maxCurX ed@Editor { insertMode = im }
  | im        = length    $ cursorLine ed
  | otherwise = lastIndex $ cursorLine ed

minCurX :: EditorC c -> Int
minCurX ed@Editor { insertMode = im }
  | im                   = -1
  | null $ cursorLine ed = -1
  | otherwise            = 0

numOfLines :: EditorC c -> Int
numOfLines Editor { buffer = buf } = length buf

cursorLine :: EditorC c -> String
cursorLine Editor { buffer = buf, cursY = cy } = buf !! cy