{-# LANGUAGE CPP #-}
module Edit(EditStop(..),editF, EditEvt(..), EditCmd(..)) where
import BgF
import Color
import Command
import DrawInWindow
import XDraw(clearArea)
import Defaults(inputFg, inputBg)
import CmdLineEnv(argReadKey, argKey)
import Dlayout(windowF)
import Edtypes
import Editfield
import Event
import Font
import Fudget
import FRequest
import Gc
import Geometry
import LayoutRequest(plainLayout,LayoutResponse(..))
import Message(message) --Message(..),
import NullF
import StateMonads
import Control.Monad(when)
import HbcUtils(apSnd)
import Xtypes
import UndoStack
import TryLayout
import Expose
import Maptrace
import GCAttrs(convFontK,fontdata2struct,FontSpec) -- instances
import InputMsg(InputMsg(InputChange))
default (Int) -- mostly for Hugs
data EditStop =
EditStopFn EditStopFn
| EditPoint Point
| EditLine EDirection
data EditCmd =
EditShowCursor Bool
| EditMove EditStop IsSelect
| EditReplace String
| EditGetText
| EditGetField
| EditGetSelection
| EditUndo
| EditRedo
data EditEvt
= EditText String
| EditField (String,String,String)
| EditCursor Rect
| EditChange (InputMsg String)
deriving (Eq, Ord)
godir wanted current = if wanted < current then ELeft else ERight
toedstop :: (a ->String->String->(a,Maybe EDirection)) -> a -> EditStopFn
toedstop sf st b a = case sf st b a of
(_,Nothing) -> EdStop
(st',Just dir) -> EdGo dir (toedstop sf st')
notnull = not . null
inputbg = argKey "editbg" inputBg
inputfg = argKey "editfg" inputFg
selectbg = argKey "selectbg" inputfg
selectfg = argKey "selectfg" inputbg
editF :: FontSpec -> F EditCmd EditEvt
editF fontspec =
let eventmask = [ExposureMask]
startcmds = [XCmd $ ChangeWindowAttributes [CWBitGravity NorthWestGravity,
CWEventMask eventmask]]
in windowF startcmds (editK fontspec)
splitwith c [] = (([], False), [])
splitwith c (a : b) =
if a == c
then (([], True), b)
else let ((x, g), y) = splitwith c b
in ((a : x, g), y)
splitwithnl = splitwith newline
tabstop = 8
untab t s =
case s of
'\t':s -> let t' = (t `div` tabstop + 1) * tabstop
in spaces (t'-t) ++ untab t' s
c:s -> c:untab (if c == newline then 0 else (t+1)) s
[] -> []
spaces n = replicate n ' '
editK fontspec =
convFontK fontspec $ \ fd ->
fontdata2struct fd $ \ font ->
changeGetBackPixel inputbg $ \bg ->
allocNamedColorPixel defaultColormap inputfg $ \fg ->
allocNamedColorPixel defaultColormap selectbg $ \sbg ->
allocNamedColorPixel defaultColormap selectfg $ \sfg ->
let fid = font_id font
creategcs fg bg cont =
wCreateGC rootGC [GCFunction GXcopy, GCFont fid,
GCForeground fg, GCBackground bg] $ \gc ->
wCreateGC gc [GCForeground bg, GCBackground fg] $ \igc -> cont (gc,igc)
in creategcs fg bg $ \drawGCs ->
creategcs sfg sbg $ \selectGCs ->
wCreateGC rootGC (invertColorGCattrs bg fg) $ \invertGC ->
let drawimagestring =
if snd (font_range font) > '\xff'
then wDrawImageString16
else wDrawImageString
getCurp = apSnd (eolx.fst) . getLnoEdge
getLCurp = getCurp . setFieldDir ELeft
getRCurp = getCurp . setFieldDir ERight
npos = next_pos font
eolx = npos . reverse . fst . splitnl
maxrmargin x s =
if null s
then x
else let (l,r) = splitnl s
in ctrace "editF1" (s,l,r,npos l) $ (x + npos l) `max` maxrmargin 0 r
lno = fst
xp = snd
p2line (Point x y) = (y `quot` lheight, x - xoffset)
line2p (l, x) = Point (x + xoffset) (l * lheight)
lheight = linespace font
move issel estop =
do field <- loadField
lastpos <- loadLastpos
invIfShowCursor
let curp = getCurp field
stoppoint wantp p@(l, x) bef aft =
let dircomp = godir wantp
dist p' = abs (lno wantp - lno p') + abs (xp wantp - xp p')
dir = dircomp p
ahead = if dir == ELeft then bef else aft
in case ahead of
[] -> (p, Nothing)
c:cs -> let p' = if c == newline
then (dirint dir + l, if dir == ERight
then 0
else eolx cs)
else (l, x + dirint dir * npos [c])
in (p', if dir == dircomp p'
then Just dir
else if dist p' < dist p
then Just dir
else Nothing)
mf sf = moveField issel field sf
(field', acc) =
case estop of
EditStopFn stopf -> mf stopf
EditPoint p -> let lp = p2line p
dir = godir lp curp
in mf (toedstop (stoppoint lp) curp)
EditLine dir -> let wantp = (dirint dir + lno curp, xp lastpos)
in mf (toedstop (stoppoint wantp) curp)
storeField field'
let ol = lno curp
nl = lno $ getCurp field'
if issel
then showlines (min ol nl) (max ol nl)
else if notnull (getSelection field)
then showSelLines field >> showlines nl nl
else invIfShowCursor
showSelLines field =
showlines (lno $ getLCurp field) (lno $ getRCurp field)
setSize (l,x) =
do old@(ol,ox) <- loadTextWidth
let new@(_,x') = (l,max x minWidth)
when (old /= new) $
do storeTextWidth new
mtrace ("before trylayout "++show(x,x',ox))
x <- toMs $ tryLayoutK $
plainLayout (line2p (l,x') `padd` llmargin) True True
mtrace "after trylayout"
storeSize x
where mtrace x = toMsc (ctrace "editF" x)
replace' s =
do field <- loadField
size <- loadSize
width <- loadWidth
let (ll,lx) = getLCurp field
uts = untab (length $ fst $ splitnl $ getBef field) s
rl = lno $ getRCurp field
field' = replaceField field uts
nls = nlines uts
nldown = nls - (rl - ll)
copy src dest h =
let srcp = line2p src
r = Rect srcp (pP width h)
in when (h>0) $
putLowMs (wCopyArea (fst drawGCs) MyWindow
r (line2p dest))
(nlines,tw) <- loadTextWidth
let changemarg new f = maxrmargin lx (new ++ fst (splitnl (getAft f)))
oldm = changemarg (getSelection field) field
newm = changemarg uts field'
tw' = if newm >= tw
then newm
else if oldm < tw
then tw
else maxrmargin 0 (getField field')
ss = (getLastLineNo field' + 1, tw')
setSize ss
storeField' field'
us <- loadUndoStack
us' <- doit us (field',ss) return
storeUndoStack us'
when (nldown /= 0) $
let tleft a = (rl + a + 1, 0)
tnl = tleft nldown
in copy (tleft 0) tnl (ycoord size - lheight * lno tnl)
showlines ll (ll + nls)
dolines first last doline = du
where du s p@(l,x) = let ((line,nl), rest) = splitwithnl s
in if l > last || null s then return p
else when (l >= first) (doline p (line,nl)) >>
du rest (if nl then (l+1,0) else (l,x+npos line))
showLine (gc,rgc) lp (line, withnl) =
do let p = line2p lp
d = pP 0 (font_ascent font)
when (xp lp == 0) $
putLowMs (clearArea (rR 0 (ycoord p) xoffset lheight) False)
when (notnull line) $
putLowMs (drawimagestring gc (p+d) line)
when withnl $
do width <- loadWidth
let pc = padd p (pP (npos line) 0)
size = Point (width - xcoord pc) lheight
putLowMs (wFillRectangle rgc (Rect pc size))
showlines first last =
do field <- loadField
showc <- loadShowCursor
let clno = lno $ getLCurp field
sel = getSelection field
aft = getAft field
takenl n s = let (l,r) = splitnl s
in if n <= 0 then l else l++newline:takenl (n-1) r
bef = reverse $ takenl (clno-first) $ getBef field
show gcs = dolines first last (showLine gcs)
show drawGCs bef (clno-nlines bef,0) >>=
show (if showc then selectGCs else drawGCs) sel >>=
show drawGCs (aft++[newline]) >>= \_ ->
when (clno >= first && clno <= last) invIfShowCursor
showCursor v = do cv <- loadShowCursor
when (v /= cv ) $
do field <- loadField
storeShowCursor v
if null (getSelection field) then
invCursor
else showSelLines field
invIfShowCursor = do cv <- loadShowCursor
when cv invCursor
invCursor = do field <- loadField
let lp = getCurp field
sel = getSelection field
when (null sel) $
let p = line2p (apSnd ((-1) +) lp)
s = pP 1 lheight
cur = Rect p s
in putLowMs (wFillRectangle invertGC cur)
redraw = do --field <- loadField
size <- loadSize
putLowMs (clearArea (Rect origin size) True)
expose r = let Line l1 l2 = rect2line r
in showlines (lno (p2line l1)) (lno (p2line l2) + 1)
undoredo d =
do us <- loadUndoStack
case d us of
Nothing -> nopMs
Just ((field,size),us') -> do storeUndoStack us'
storeField' field
setSize size
redraw
storeField' field' =
do storeField field'
putHighMs (EditChange $ InputChange $ getField field')
puttext' f = do field <- loadField
putHighMs (f field)
puttext f = puttext' (EditText . f)
putCursor =
do field <- loadField
let lastpos = getCurp field
putHighMs (EditCursor $ Rect (line2p lastpos `psub` Point xoffset 0)
(Point xoffset lheight `padd` llmargin))
handleLow msg =
case msg of
XEvt (Expose r aft) -> toMs (maxExposeK False r aft) >>= expose
XEvt (GraphicsExpose r aft _ _) -> toMs (maxExposeK True r aft) >>= expose
LEvt (LayoutSize s) -> storeSize s
_ -> nopMs
handleHigh cmd =
do case cmd of
EditShowCursor s -> showCursor s
EditMove estop issel -> move issel estop
EditReplace s -> replace' s
EditGetText -> puttext getField
EditGetField -> puttext' (EditField . getField')
EditGetSelection -> puttext getSelection
EditUndo -> undoredo undo
EditRedo -> undoredo redo
putCursor
field <- loadField
let lastpos = getCurp field
case cmd of
EditMove (EditLine _) _ -> nopMs
_ -> storeLastpos lastpos
proc = do message handleLow handleHigh =<< getKs
proc
in stateK initstate (setSize (1,0) >> proc) nullK
minWidth = 10
xoffset = 2
llmargin = Point 2 2
defaultuslimit = Nothing
uslimit = let ul = argReadKey "undodepth" (-1)
in if ul == -1 then defaultuslimit else Just ul
data EditState a = S { shocur :: Bool,
twidth :: (Int,Int),
undostack :: UndoStack a,
field :: EditField,
size :: Point,
lastpos :: (Int,Int)
}
--initstate = (False,(1,0),undoStack uslimit, createField "", origin, (0, 0))
initstate = S False (1,0) (undoStack uslimit) (createField "") origin (0, 0)
loadShowCursor = fieldMs shocur
loadTextWidth = fieldMs twidth
loadUndoStack = fieldMs undostack
loadField = fieldMs field
loadSize = fieldMs size
loadLastpos = fieldMs lastpos
--loadWidth = loadSize >>= \size -> return (xcoord size)
loadWidth = fmap xcoord loadSize
#define MODMS(lbl) ( \ lbl -> (modMs ( \ s -> s { lbl=lbl } )))
storeShowCursor = MODMS(shocur)
storeTextWidth = MODMS(twidth)
storeUndoStack = MODMS(undostack)
storeField = MODMS(field)
storeSize = MODMS(size)
storeLastpos = MODMS(lastpos)