{-# 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)
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)
import InputMsg(InputMsg(InputChange))
default (Int)
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 (EditEvt -> EditEvt -> Bool
(EditEvt -> EditEvt -> Bool)
-> (EditEvt -> EditEvt -> Bool) -> Eq EditEvt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EditEvt -> EditEvt -> Bool
$c/= :: EditEvt -> EditEvt -> Bool
== :: EditEvt -> EditEvt -> Bool
$c== :: EditEvt -> EditEvt -> Bool
Eq, Eq EditEvt
Eq EditEvt
-> (EditEvt -> EditEvt -> Ordering)
-> (EditEvt -> EditEvt -> Bool)
-> (EditEvt -> EditEvt -> Bool)
-> (EditEvt -> EditEvt -> Bool)
-> (EditEvt -> EditEvt -> Bool)
-> (EditEvt -> EditEvt -> EditEvt)
-> (EditEvt -> EditEvt -> EditEvt)
-> Ord EditEvt
EditEvt -> EditEvt -> Bool
EditEvt -> EditEvt -> Ordering
EditEvt -> EditEvt -> EditEvt
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EditEvt -> EditEvt -> EditEvt
$cmin :: EditEvt -> EditEvt -> EditEvt
max :: EditEvt -> EditEvt -> EditEvt
$cmax :: EditEvt -> EditEvt -> EditEvt
>= :: EditEvt -> EditEvt -> Bool
$c>= :: EditEvt -> EditEvt -> Bool
> :: EditEvt -> EditEvt -> Bool
$c> :: EditEvt -> EditEvt -> Bool
<= :: EditEvt -> EditEvt -> Bool
$c<= :: EditEvt -> EditEvt -> Bool
< :: EditEvt -> EditEvt -> Bool
$c< :: EditEvt -> EditEvt -> Bool
compare :: EditEvt -> EditEvt -> Ordering
$ccompare :: EditEvt -> EditEvt -> Ordering
$cp1Ord :: Eq EditEvt
Ord)
godir :: a -> a -> EDirection
godir a
wanted a
current = if a
wanted a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
current then EDirection
ELeft else EDirection
ERight
toedstop :: (a ->String->String->(a,Maybe EDirection)) -> a -> EditStopFn
toedstop :: (a -> String -> String -> (a, Maybe EDirection)) -> a -> EditStopFn
toedstop a -> String -> String -> (a, Maybe EDirection)
sf a
st String
b String
a = case a -> String -> String -> (a, Maybe EDirection)
sf a
st String
b String
a of
(a
_,Maybe EDirection
Nothing) -> EditStopChoice
EdStop
(a
st',Just EDirection
dir) -> EDirection -> EditStopFn -> EditStopChoice
EdGo EDirection
dir ((a -> String -> String -> (a, Maybe EDirection)) -> a -> EditStopFn
forall a.
(a -> String -> String -> (a, Maybe EDirection)) -> a -> EditStopFn
toedstop a -> String -> String -> (a, Maybe EDirection)
sf a
st')
notnull :: [a] -> Bool
notnull = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
inputbg :: String
inputbg = String -> String -> String
argKey String
"editbg" String
inputBg
inputfg :: String
inputfg = String -> String -> String
argKey String
"editfg" String
inputFg
selectbg :: String
selectbg = String -> String -> String
argKey String
"selectbg" String
inputfg
selectfg :: String
selectfg = String -> String -> String
argKey String
"selectfg" String
inputbg
editF :: FontSpec -> F EditCmd EditEvt
editF :: FontSpec -> F EditCmd EditEvt
editF FontSpec
fontspec =
let eventmask :: [EventMask]
eventmask = [EventMask
ExposureMask]
startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd (XCommand -> FRequest) -> XCommand -> FRequest
forall a b. (a -> b) -> a -> b
$ [WindowAttributes] -> XCommand
ChangeWindowAttributes [Gravity -> WindowAttributes
CWBitGravity Gravity
NorthWestGravity,
[EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask]]
in [FRequest] -> K EditCmd EditEvt -> F EditCmd EditEvt
forall a b. [FRequest] -> K a b -> F a b
windowF [FRequest]
startcmds (FontSpec -> K EditCmd EditEvt
forall a. (FontGen a, Show a) => a -> K EditCmd EditEvt
editK FontSpec
fontspec)
splitwith :: a -> [a] -> (([a], Bool), [a])
splitwith a
c [] = (([], Bool
False), [])
splitwith a
c (a
a : [a]
b) =
if a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c
then (([], Bool
True), [a]
b)
else let (([a]
x, Bool
g), [a]
y) = a -> [a] -> (([a], Bool), [a])
splitwith a
c [a]
b
in ((a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
x, Bool
g), [a]
y)
splitwithnl :: String -> ((String, Bool), String)
splitwithnl = Char -> String -> ((String, Bool), String)
forall a. Eq a => a -> [a] -> (([a], Bool), [a])
splitwith Char
newline
tabstop :: Int
tabstop = Int
8
untab :: Int -> String -> String
untab Int
t String
s =
case String
s of
Char
'\t':String
s -> let t' :: Int
t' = (Int
t Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
tabstop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tabstop
in Int -> String
spaces (Int
t'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
untab Int
t' String
s
Char
c:String
s -> Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Int -> String -> String
untab (if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
newline then Int
0 else (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) String
s
[] -> []
spaces :: Int -> String
spaces Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '
editK :: a -> K EditCmd EditEvt
editK a
fontspec =
a -> (FontData -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f, Show a) =>
a -> (FontData -> f i o) -> f i o
convFontK a
fontspec ((FontData -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (FontData -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \ FontData
fd ->
FontData -> (FontStruct -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall p. FontData -> (FontStruct -> p) -> p
fontdata2struct FontData
fd ((FontStruct -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (FontStruct -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \ FontStruct
font ->
String -> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a i o.
(Show a, ColorGen a) =>
a -> (Pixel -> K i o) -> K i o
changeGetBackPixel String
inputbg ((Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \Pixel
bg ->
ColormapId
-> String -> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
inputfg ((Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
ColormapId
-> String -> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
selectbg ((Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \Pixel
sbg ->
ColormapId
-> String -> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
ColormapId -> String -> Cont (f b ho) Pixel
allocNamedColorPixel ColormapId
defaultColormap String
selectfg ((Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (Pixel -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \Pixel
sfg ->
let fid :: FontId
fid = FontStruct -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStruct
font
creategcs :: Pixel -> Pixel -> ((GCId, GCId) -> f b ho) -> f b ho
creategcs Pixel
fg Pixel
bg (GCId, GCId) -> f b ho
cont =
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC [GCFunction -> GCAttributes Pixel FontId
forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, FontId -> GCAttributes Pixel FontId
forall a b. b -> GCAttributes a b
GCFont FontId
fid,
Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
fg, Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
bg] ((GCId -> f b ho) -> f b ho) -> (GCId -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \GCId
gc ->
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
gc [Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCForeground Pixel
bg, Pixel -> GCAttributes Pixel FontId
forall a b. a -> GCAttributes a b
GCBackground Pixel
fg] ((GCId -> f b ho) -> f b ho) -> (GCId -> f b ho) -> f b ho
forall a b. (a -> b) -> a -> b
$ \GCId
igc -> (GCId, GCId) -> f b ho
cont (GCId
gc,GCId
igc)
in Pixel
-> Pixel
-> ((GCId, GCId) -> K EditCmd EditEvt)
-> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
Pixel -> Pixel -> ((GCId, GCId) -> f b ho) -> f b ho
creategcs Pixel
fg Pixel
bg (((GCId, GCId) -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> ((GCId, GCId) -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \(GCId, GCId)
drawGCs ->
Pixel
-> Pixel
-> ((GCId, GCId) -> K EditCmd EditEvt)
-> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
Pixel -> Pixel -> ((GCId, GCId) -> f b ho) -> f b ho
creategcs Pixel
sfg Pixel
sbg (((GCId, GCId) -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> ((GCId, GCId) -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \(GCId, GCId)
selectGCs ->
GCId
-> [GCAttributes Pixel FontId]
-> (GCId -> K EditCmd EditEvt)
-> K EditCmd EditEvt
forall (f :: * -> * -> *) b ho.
FudgetIO f =>
GCId -> [GCAttributes Pixel FontId] -> (GCId -> f b ho) -> f b ho
wCreateGC GCId
rootGC (Pixel -> Pixel -> [GCAttributes Pixel FontId]
forall b. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
bg Pixel
fg) ((GCId -> K EditCmd EditEvt) -> K EditCmd EditEvt)
-> (GCId -> K EditCmd EditEvt) -> K EditCmd EditEvt
forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
let drawimagestring :: GCId -> Point -> String -> FRequest
drawimagestring =
if (Char, Char) -> Char
forall a b. (a, b) -> b
snd (FontStruct -> (Char, Char)
forall per_char. FontStructF per_char -> (Char, Char)
font_range FontStruct
font) Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
'\xff'
then GCId -> Point -> String -> FRequest
wDrawImageString16
else GCId -> Point -> String -> FRequest
wDrawImageString
getCurp :: EditField -> (Int, Int)
getCurp = ((String, String) -> Int) -> (Int, (String, String)) -> (Int, Int)
forall t b a. (t -> b) -> (a, t) -> (a, b)
apSnd (String -> Int
eolx(String -> Int)
-> ((String, String) -> String) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, String) -> String
forall a b. (a, b) -> a
fst) ((Int, (String, String)) -> (Int, Int))
-> (EditField -> (Int, (String, String)))
-> EditField
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditField -> (Int, (String, String))
getLnoEdge
getLCurp :: EditField -> (Int, Int)
getLCurp = EditField -> (Int, Int)
getCurp (EditField -> (Int, Int))
-> (EditField -> EditField) -> EditField -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EDirection -> EditField -> EditField
setFieldDir EDirection
ELeft
getRCurp :: EditField -> (Int, Int)
getRCurp = EditField -> (Int, Int)
getCurp (EditField -> (Int, Int))
-> (EditField -> EditField) -> EditField -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EDirection -> EditField -> EditField
setFieldDir EDirection
ERight
npos :: String -> Int
npos = FontStruct -> String -> Int
next_pos FontStruct
font
eolx :: String -> Int
eolx = String -> Int
npos (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
splitnl
maxrmargin :: Int -> String -> Int
maxrmargin Int
x String
s =
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
then Int
x
else let (String
l,String
r) = String -> (String, String)
splitnl String
s
in String -> (String, String, String, Int) -> Int -> Int
forall a1 a2. Show a1 => String -> a1 -> a2 -> a2
ctrace String
"editF1" (String
s,String
l,String
r,String -> Int
npos String
l) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
npos String
l) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int -> String -> Int
maxrmargin Int
0 String
r
lno :: (a, b) -> a
lno = (a, b) -> a
forall a b. (a, b) -> a
fst
xp :: (a, b) -> b
xp = (a, b) -> b
forall a b. (a, b) -> b
snd
p2line :: Point -> (Int, Int)
p2line (Point Int
x Int
y) = (Int
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
lheight, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xoffset)
line2p :: (Int, Int) -> Point
line2p (Int
l, Int
x) = Int -> Int -> Point
Point (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xoffset) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
lheight)
lheight :: Int
lheight = FontStruct -> Int
forall per_char. FontStructF per_char -> Int
linespace FontStruct
font
move :: Bool -> EditStop -> Mk (EditState a -> K hi ho) ()
move Bool
issel EditStop
estop =
do EditField
field <- Ms (K hi ho) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
(Int, Int)
lastpos <- Ms (K hi ho) (EditState a) (Int, Int)
forall k a. Ms k (EditState a) (Int, Int)
loadLastpos
Mk (EditState a -> K hi ho) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
invIfShowCursor
let curp :: (Int, Int)
curp = EditField -> (Int, Int)
getCurp EditField
field
stoppoint :: (Int, Int)
-> (Int, Int) -> String -> String -> ((Int, Int), Maybe EDirection)
stoppoint (Int, Int)
wantp p :: (Int, Int)
p@(Int
l, Int
x) String
bef String
aft =
let dircomp :: (Int, Int) -> EDirection
dircomp = (Int, Int) -> (Int, Int) -> EDirection
forall a. Ord a => a -> a -> EDirection
godir (Int, Int)
wantp
dist :: (Int, Int) -> Int
dist (Int, Int)
p' = Int -> Int
forall a. Num a => a -> a
abs ((Int, Int) -> Int
forall a b. (a, b) -> a
lno (Int, Int)
wantp Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int, Int) -> Int
forall a b. (a, b) -> a
lno (Int, Int)
p') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Num a => a -> a
abs ((Int, Int) -> Int
forall a b. (a, b) -> b
xp (Int, Int)
wantp Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int, Int) -> Int
forall a b. (a, b) -> b
xp (Int, Int)
p')
dir :: EDirection
dir = (Int, Int) -> EDirection
dircomp (Int, Int)
p
ahead :: String
ahead = if EDirection
dir EDirection -> EDirection -> Bool
forall a. Eq a => a -> a -> Bool
== EDirection
ELeft then String
bef else String
aft
in case String
ahead of
[] -> ((Int, Int)
p, Maybe EDirection
forall a. Maybe a
Nothing)
Char
c:String
cs -> let p' :: (Int, Int)
p' = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
newline
then (EDirection -> Int
forall p. Num p => EDirection -> p
dirint EDirection
dir Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l, if EDirection
dir EDirection -> EDirection -> Bool
forall a. Eq a => a -> a -> Bool
== EDirection
ERight
then Int
0
else String -> Int
eolx String
cs)
else (Int
l, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ EDirection -> Int
forall p. Num p => EDirection -> p
dirint EDirection
dir Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
npos [Char
c])
in ((Int, Int)
p', if EDirection
dir EDirection -> EDirection -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int) -> EDirection
dircomp (Int, Int)
p'
then EDirection -> Maybe EDirection
forall a. a -> Maybe a
Just EDirection
dir
else if (Int, Int) -> Int
dist (Int, Int)
p' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int) -> Int
dist (Int, Int)
p
then EDirection -> Maybe EDirection
forall a. a -> Maybe a
Just EDirection
dir
else Maybe EDirection
forall a. Maybe a
Nothing)
mf :: EditStopFn -> (EditField, String)
mf EditStopFn
sf = Bool -> EditField -> EditStopFn -> (EditField, String)
moveField Bool
issel EditField
field EditStopFn
sf
(EditField
field', String
acc) =
case EditStop
estop of
EditStopFn stopf -> EditStopFn -> (EditField, String)
mf EditStopFn
stopf
EditPoint p -> let lp :: (Int, Int)
lp = Point -> (Int, Int)
p2line Point
p
dir :: EDirection
dir = (Int, Int) -> (Int, Int) -> EDirection
forall a. Ord a => a -> a -> EDirection
godir (Int, Int)
lp (Int, Int)
curp
in EditStopFn -> (EditField, String)
mf (((Int, Int) -> String -> String -> ((Int, Int), Maybe EDirection))
-> (Int, Int) -> EditStopFn
forall a.
(a -> String -> String -> (a, Maybe EDirection)) -> a -> EditStopFn
toedstop ((Int, Int)
-> (Int, Int) -> String -> String -> ((Int, Int), Maybe EDirection)
stoppoint (Int, Int)
lp) (Int, Int)
curp)
EditLine dir -> let wantp :: (Int, Int)
wantp = (EDirection -> Int
forall p. Num p => EDirection -> p
dirint EDirection
dir Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> a
lno (Int, Int)
curp, (Int, Int) -> Int
forall a b. (a, b) -> b
xp (Int, Int)
lastpos)
in EditStopFn -> (EditField, String)
mf (((Int, Int) -> String -> String -> ((Int, Int), Maybe EDirection))
-> (Int, Int) -> EditStopFn
forall a.
(a -> String -> String -> (a, Maybe EDirection)) -> a -> EditStopFn
toedstop ((Int, Int)
-> (Int, Int) -> String -> String -> ((Int, Int), Maybe EDirection)
stoppoint (Int, Int)
wantp) (Int, Int)
curp)
EditField -> Mk (EditState a -> K hi ho) ()
forall k a. EditField -> Msc k (EditState a)
storeField EditField
field'
let ol :: Int
ol = (Int, Int) -> Int
forall a b. (a, b) -> a
lno (Int, Int)
curp
nl :: Int
nl = (Int, Int) -> Int
forall a b. (a, b) -> a
lno ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ EditField -> (Int, Int)
getCurp EditField
field'
if Bool
issel
then Int -> Int -> Mk (EditState a -> K hi ho) ()
forall a hi ho. Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
ol Int
nl) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
ol Int
nl)
else if String -> Bool
forall a. [a] -> Bool
notnull (EditField -> String
getSelection EditField
field)
then EditField -> Mk (EditState a -> K hi ho) ()
forall a hi ho. EditField -> Mk (EditState a -> K hi ho) ()
showSelLines EditField
field Mk (EditState a -> K hi ho) ()
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> Mk (EditState a -> K hi ho) ()
forall a hi ho. Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines Int
nl Int
nl
else Mk (EditState a -> K hi ho) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
invIfShowCursor
showSelLines :: EditField -> Mk (EditState a -> K hi ho) ()
showSelLines EditField
field =
Int -> Int -> Mk (EditState a -> K hi ho) ()
forall a hi ho. Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines ((Int, Int) -> Int
forall a b. (a, b) -> a
lno ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ EditField -> (Int, Int)
getLCurp EditField
field) ((Int, Int) -> Int
forall a b. (a, b) -> a
lno ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ EditField -> (Int, Int)
getRCurp EditField
field)
setSize :: (Int, Int) -> Mk (EditState a -> K b c) ()
setSize (Int
l,Int
x) =
do old :: (Int, Int)
old@(Int
ol,Int
ox) <- Ms (K b c) (EditState a) (Int, Int)
forall k a. Ms k (EditState a) (Int, Int)
loadTextWidth
let new :: (Int, Int)
new@(Int
_,Int
x') = (Int
l,Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x Int
minWidth)
Bool
-> Mk (EditState a -> K b c) () -> Mk (EditState a -> K b c) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, Int)
old (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int, Int)
new) (Mk (EditState a -> K b c) () -> Mk (EditState a -> K b c) ())
-> Mk (EditState a -> K b c) () -> Mk (EditState a -> K b c) ()
forall a b. (a -> b) -> a -> b
$
do (Int, Int) -> Mk (EditState a -> K b c) ()
forall k a. (Int, Int) -> Msc k (EditState a)
storeTextWidth (Int, Int)
new
String -> Mk (EditState a -> K b c) ()
forall a1 k r. Show a1 => a1 -> Msc k r
mtrace (String
"before trylayout "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int, Int, Int) -> String
forall a. Show a => a -> String
show(Int
x,Int
x',Int
ox))
Point
x <- Cont (K b c) Point -> Ms (K b c) (EditState a) Point
forall k r s. Cont k r -> Ms k s r
toMs (Cont (K b c) Point -> Ms (K b c) (EditState a) Point)
-> Cont (K b c) Point -> Ms (K b c) (EditState a) Point
forall a b. (a -> b) -> a -> b
$ LayoutRequest -> Cont (K b c) Point
forall b c. LayoutRequest -> Cont (K b c) Point
tryLayoutK (LayoutRequest -> Cont (K b c) Point)
-> LayoutRequest -> Cont (K b c) Point
forall a b. (a -> b) -> a -> b
$
Point -> Bool -> Bool -> LayoutRequest
plainLayout ((Int, Int) -> Point
line2p (Int
l,Int
x') Point -> Point -> Point
`padd` Point
llmargin) Bool
True Bool
True
String -> Mk (EditState a -> K b c) ()
forall a1 k r. Show a1 => a1 -> Msc k r
mtrace String
"after trylayout"
Point -> Mk (EditState a -> K b c) ()
forall k a. Point -> Msc k (EditState a)
storeSize Point
x
where mtrace :: a1 -> Msc k r
mtrace a1
x = (k -> k) -> Msc k r
forall k r. (k -> k) -> Msc k r
toMsc (String -> a1 -> k -> k
forall a1 a2. Show a1 => String -> a1 -> a2 -> a2
ctrace String
"editF" a1
x)
replace' :: String -> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
replace' String
s =
do EditField
field <- Ms (K b EditEvt) (EditState (EditField, (Int, Int))) EditField
forall k a. Ms k (EditState a) EditField
loadField
Point
size <- Ms (K b EditEvt) (EditState (EditField, (Int, Int))) Point
forall k a. Ms k (EditState a) Point
loadSize
Int
width <- Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) Int
forall a k. Mk (EditState a -> k) Int
loadWidth
let (Int
ll,Int
lx) = EditField -> (Int, Int)
getLCurp EditField
field
uts :: String
uts = Int -> String -> String
untab (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitnl (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ EditField -> String
getBef EditField
field) String
s
rl :: Int
rl = (Int, Int) -> Int
forall a b. (a, b) -> a
lno ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ EditField -> (Int, Int)
getRCurp EditField
field
field' :: EditField
field' = EditField -> String -> EditField
replaceField EditField
field String
uts
nls :: Int
nls = String -> Int
nlines String
uts
nldown :: Int
nldown = Int
nls Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
rl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ll)
copy :: (Int, Int) -> (Int, Int) -> Int -> Mk (r -> f hi ho) ()
copy (Int, Int)
src (Int, Int)
dest Int
h =
let srcp :: Point
srcp = (Int, Int) -> Point
line2p (Int, Int)
src
r :: Rect
r = Point -> Point -> Rect
Rect Point
srcp (Int -> Int -> Point
pP Int
width Int
h)
in Bool -> Mk (r -> f hi ho) () -> Mk (r -> f hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
hInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) (Mk (r -> f hi ho) () -> Mk (r -> f hi ho) ())
-> Mk (r -> f hi ho) () -> Mk (r -> f hi ho) ()
forall a b. (a -> b) -> a -> b
$
FRequest -> Mk (r -> f hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (GCId -> Drawable -> Rect -> Point -> FRequest
wCopyArea ((GCId, GCId) -> GCId
forall a b. (a, b) -> a
fst (GCId, GCId)
drawGCs) Drawable
MyWindow
Rect
r ((Int, Int) -> Point
line2p (Int, Int)
dest))
(Int
nlines,Int
tw) <- Ms (K b EditEvt) (EditState (EditField, (Int, Int))) (Int, Int)
forall k a. Ms k (EditState a) (Int, Int)
loadTextWidth
let changemarg :: String -> EditField -> Int
changemarg String
new EditField
f = Int -> String -> Int
maxrmargin Int
lx (String
new String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a b. (a, b) -> a
fst (String -> (String, String)
splitnl (EditField -> String
getAft EditField
f)))
oldm :: Int
oldm = String -> EditField -> Int
changemarg (EditField -> String
getSelection EditField
field) EditField
field
newm :: Int
newm = String -> EditField -> Int
changemarg String
uts EditField
field'
tw' :: Int
tw' = if Int
newm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tw
then Int
newm
else if Int
oldm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tw
then Int
tw
else Int -> String -> Int
maxrmargin Int
0 (EditField -> String
getField EditField
field')
ss :: (Int, Int)
ss = (EditField -> Int
getLastLineNo EditField
field' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
tw')
(Int, Int)
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall a b c. (Int, Int) -> Mk (EditState a -> K b c) ()
setSize (Int, Int)
ss
EditField
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall (sp :: * -> * -> *) a i.
StreamProcIO sp =>
EditField -> Mk (EditState a -> sp i EditEvt) ()
storeField' EditField
field'
UndoStack (EditField, (Int, Int))
us <- Ms
(K b EditEvt)
(EditState (EditField, (Int, Int)))
(UndoStack (EditField, (Int, Int)))
forall k a. Ms k (EditState a) (UndoStack a)
loadUndoStack
UndoStack (EditField, (Int, Int))
us' <- UndoStack (EditField, (Int, Int))
-> (EditField, (Int, Int))
-> (UndoStack (EditField, (Int, Int))
-> Ms
(K b EditEvt)
(EditState (EditField, (Int, Int)))
(UndoStack (EditField, (Int, Int))))
-> Ms
(K b EditEvt)
(EditState (EditField, (Int, Int)))
(UndoStack (EditField, (Int, Int)))
forall a c. UndoStack a -> a -> (UndoStack a -> c) -> c
doit UndoStack (EditField, (Int, Int))
us (EditField
field',(Int, Int)
ss) UndoStack (EditField, (Int, Int))
-> Ms
(K b EditEvt)
(EditState (EditField, (Int, Int)))
(UndoStack (EditField, (Int, Int)))
forall (m :: * -> *) a. Monad m => a -> m a
return
UndoStack (EditField, (Int, Int))
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall a k. UndoStack a -> Msc k (EditState a)
storeUndoStack UndoStack (EditField, (Int, Int))
us'
Bool
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nldown Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ())
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall a b. (a -> b) -> a -> b
$
let tleft :: Int -> (Int, b)
tleft Int
a = (Int
rl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, b
0)
tnl :: (Int, Int)
tnl = Int -> (Int, Int)
forall b. Num b => Int -> (Int, b)
tleft Int
nldown
in (Int, Int)
-> (Int, Int)
-> Int
-> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall (f :: * -> * -> *) r hi ho.
FudgetIO f =>
(Int, Int) -> (Int, Int) -> Int -> Mk (r -> f hi ho) ()
copy (Int -> (Int, Int)
forall b. Num b => Int -> (Int, b)
tleft Int
0) (Int, Int)
tnl (Point -> Int
ycoord Point
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lheight Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int, Int) -> Int
forall a b. (a, b) -> a
lno (Int, Int)
tnl)
Int
-> Int -> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
forall a hi ho. Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines Int
ll (Int
ll Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nls)
dolines :: a
-> a
-> ((a, Int) -> (String, Bool) -> m ())
-> String
-> (a, Int)
-> m (a, Int)
dolines a
first a
last (a, Int) -> (String, Bool) -> m ()
doline = String -> (a, Int) -> m (a, Int)
du
where du :: String -> (a, Int) -> m (a, Int)
du String
s p :: (a, Int)
p@(a
l,Int
x) = let ((String
line,Bool
nl), String
rest) = String -> ((String, Bool), String)
splitwithnl String
s
in if a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
last Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then (a, Int) -> m (a, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (a, Int)
p
else Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
first) ((a, Int) -> (String, Bool) -> m ()
doline (a, Int)
p (String
line,Bool
nl)) m () -> m (a, Int) -> m (a, Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
String -> (a, Int) -> m (a, Int)
du String
rest (if Bool
nl then (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1,Int
0) else (a
l,Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+String -> Int
npos String
line))
showLine :: (GCId, GCId)
-> (Int, Int) -> (String, Bool) -> Mk (EditState a -> f hi ho) ()
showLine (GCId
gc,GCId
rgc) (Int, Int)
lp (String
line, Bool
withnl) =
do let p :: Point
p = (Int, Int) -> Point
line2p (Int, Int)
lp
d :: Point
d = Int -> Int -> Point
pP Int
0 (FontStruct -> Int
forall per_char. FontStructF per_char -> Int
font_ascent FontStruct
font)
Bool
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Int, Int) -> Int
forall a b. (a, b) -> b
xp (Int, Int)
lp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ())
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall a b. (a -> b) -> a -> b
$
FRequest -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (Rect -> Bool -> FRequest
clearArea (Int -> Int -> Int -> Int -> Rect
rR Int
0 (Point -> Int
ycoord Point
p) Int
xoffset Int
lheight) Bool
False)
Bool
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
notnull String
line) (Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ())
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall a b. (a -> b) -> a -> b
$
FRequest -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (GCId -> Point -> String -> FRequest
drawimagestring GCId
gc (Point
pPoint -> Point -> Point
forall a. Num a => a -> a -> a
+Point
d) String
line)
Bool
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withnl (Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ())
-> Mk (EditState a -> f hi ho) () -> Mk (EditState a -> f hi ho) ()
forall a b. (a -> b) -> a -> b
$
do Int
width <- Mk (EditState a -> f hi ho) Int
forall a k. Mk (EditState a -> k) Int
loadWidth
let pc :: Point
pc = Point -> Point -> Point
padd Point
p (Int -> Int -> Point
pP (String -> Int
npos String
line) Int
0)
size :: Point
size = Int -> Int -> Point
Point (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Point -> Int
xcoord Point
pc) Int
lheight
FRequest -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (GCId -> Rect -> FRequest
wFillRectangle GCId
rgc (Point -> Point -> Rect
Rect Point
pc Point
size))
showlines :: Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines Int
first Int
last =
do EditField
field <- Ms (K hi ho) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
Bool
showc <- Ms (K hi ho) (EditState a) Bool
forall k a. Ms k (EditState a) Bool
loadShowCursor
let clno :: Int
clno = (Int, Int) -> Int
forall a b. (a, b) -> a
lno ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ EditField -> (Int, Int)
getLCurp EditField
field
sel :: String
sel = EditField -> String
getSelection EditField
field
aft :: String
aft = EditField -> String
getAft EditField
field
takenl :: t -> String -> String
takenl t
n String
s = let (String
l,String
r) = String -> (String, String)
splitnl String
s
in if t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 then String
l else String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
newlineChar -> String -> String
forall a. a -> [a] -> [a]
:t -> String -> String
takenl (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) String
r
bef :: String
bef = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall t. (Ord t, Num t) => t -> String -> String
takenl (Int
clnoInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
first) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ EditField -> String
getBef EditField
field
show :: (GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> f hi ho) (Int, Int)
show (GCId, GCId)
gcs = Int
-> Int
-> ((Int, Int) -> (String, Bool) -> Mk (EditState a -> f hi ho) ())
-> String
-> (Int, Int)
-> Mk (EditState a -> f hi ho) (Int, Int)
forall a (m :: * -> *).
(Ord a, Monad m, Num a) =>
a
-> a
-> ((a, Int) -> (String, Bool) -> m ())
-> String
-> (a, Int)
-> m (a, Int)
dolines Int
first Int
last ((GCId, GCId)
-> (Int, Int) -> (String, Bool) -> Mk (EditState a -> f hi ho) ()
forall (f :: * -> * -> *) a hi ho.
FudgetIO f =>
(GCId, GCId)
-> (Int, Int) -> (String, Bool) -> Mk (EditState a -> f hi ho) ()
showLine (GCId, GCId)
gcs)
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> K hi ho) (Int, Int)
forall (f :: * -> * -> *) a hi ho.
FudgetIO f =>
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> f hi ho) (Int, Int)
show (GCId, GCId)
drawGCs String
bef (Int
clnoInt -> Int -> Int
forall a. Num a => a -> a -> a
-String -> Int
nlines String
bef,Int
0) Mk (EditState a -> K hi ho) (Int, Int)
-> ((Int, Int) -> Mk (EditState a -> K hi ho) (Int, Int))
-> Mk (EditState a -> K hi ho) (Int, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> K hi ho) (Int, Int)
forall (f :: * -> * -> *) a hi ho.
FudgetIO f =>
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> f hi ho) (Int, Int)
show (if Bool
showc then (GCId, GCId)
selectGCs else (GCId, GCId)
drawGCs) String
sel Mk (EditState a -> K hi ho) (Int, Int)
-> ((Int, Int) -> Mk (EditState a -> K hi ho) (Int, Int))
-> Mk (EditState a -> K hi ho) (Int, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> K hi ho) (Int, Int)
forall (f :: * -> * -> *) a hi ho.
FudgetIO f =>
(GCId, GCId)
-> String -> (Int, Int) -> Mk (EditState a -> f hi ho) (Int, Int)
show (GCId, GCId)
drawGCs (String
aftString -> String -> String
forall a. [a] -> [a] -> [a]
++[Char
newline]) Mk (EditState a -> K hi ho) (Int, Int)
-> ((Int, Int) -> Mk (EditState a -> K hi ho) ())
-> Mk (EditState a -> K hi ho) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int, Int)
_ ->
Bool
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
clno Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
first Bool -> Bool -> Bool
&& Int
clno Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
last) Mk (EditState a -> K hi ho) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
invIfShowCursor
showCursor :: Bool -> Mk (EditState a -> K hi ho) ()
showCursor Bool
v = do Bool
cv <- Ms (K hi ho) (EditState a) Bool
forall k a. Ms k (EditState a) Bool
loadShowCursor
Bool
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
v Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
cv ) (Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ())
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall a b. (a -> b) -> a -> b
$
do EditField
field <- Ms (K hi ho) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
Bool -> Mk (EditState a -> K hi ho) ()
forall k a. Bool -> Msc k (EditState a)
storeShowCursor Bool
v
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EditField -> String
getSelection EditField
field) then
Mk (EditState a -> K hi ho) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
invCursor
else EditField -> Mk (EditState a -> K hi ho) ()
forall a hi ho. EditField -> Mk (EditState a -> K hi ho) ()
showSelLines EditField
field
invIfShowCursor :: Mk (EditState a -> K hi ho) ()
invIfShowCursor = do Bool
cv <- Ms (K hi ho) (EditState a) Bool
forall k a. Ms k (EditState a) Bool
loadShowCursor
Bool
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cv Mk (EditState a -> K hi ho) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
invCursor
invCursor :: Mk (EditState a -> K hi ho) ()
invCursor = do EditField
field <- Ms (K hi ho) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
let lp :: (Int, Int)
lp = EditField -> (Int, Int)
getCurp EditField
field
sel :: String
sel = EditField -> String
getSelection EditField
field
Bool
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
sel) (Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ())
-> Mk (EditState a -> K hi ho) () -> Mk (EditState a -> K hi ho) ()
forall a b. (a -> b) -> a -> b
$
let p :: Point
p = (Int, Int) -> Point
line2p ((Int -> Int) -> (Int, Int) -> (Int, Int)
forall t b a. (t -> b) -> (a, t) -> (a, b)
apSnd ((-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int, Int)
lp)
s :: Point
s = Int -> Int -> Point
pP Int
1 Int
lheight
cur :: Rect
cur = Point -> Point -> Rect
Rect Point
p Point
s
in FRequest -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (GCId -> Rect -> FRequest
wFillRectangle GCId
invertGC Rect
cur)
redraw :: Mk (EditState a -> K hi ho) ()
redraw = do
Point
size <- Ms (K hi ho) (EditState a) Point
forall k a. Ms k (EditState a) Point
loadSize
FRequest -> Mk (EditState a -> K hi ho) ()
forall (f :: * -> * -> *) hi ho r.
FudgetIO f =>
FRequest -> Msc (f hi ho) r
putLowMs (Rect -> Bool -> FRequest
clearArea (Point -> Point -> Rect
Rect Point
origin Point
size) Bool
True)
expose :: Rect -> Mk (EditState a -> K hi ho) ()
expose Rect
r = let Line Point
l1 Point
l2 = Rect -> Line
rect2line Rect
r
in Int -> Int -> Mk (EditState a -> K hi ho) ()
forall a hi ho. Int -> Int -> Mk (EditState a -> K hi ho) ()
showlines ((Int, Int) -> Int
forall a b. (a, b) -> a
lno (Point -> (Int, Int)
p2line Point
l1)) ((Int, Int) -> Int
forall a b. (a, b) -> a
lno (Point -> (Int, Int)
p2line Point
l2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
undoredo :: (UndoStack a -> Maybe ((EditField, (Int, Int)), UndoStack a))
-> Mk (EditState a -> K i EditEvt) ()
undoredo UndoStack a -> Maybe ((EditField, (Int, Int)), UndoStack a)
d =
do UndoStack a
us <- Ms (K i EditEvt) (EditState a) (UndoStack a)
forall k a. Ms k (EditState a) (UndoStack a)
loadUndoStack
case UndoStack a -> Maybe ((EditField, (Int, Int)), UndoStack a)
d UndoStack a
us of
Maybe ((EditField, (Int, Int)), UndoStack a)
Nothing -> Mk (EditState a -> K i EditEvt) ()
forall k s. Msc k s
nopMs
Just ((EditField
field,(Int, Int)
size),UndoStack a
us') -> do UndoStack a -> Mk (EditState a -> K i EditEvt) ()
forall a k. UndoStack a -> Msc k (EditState a)
storeUndoStack UndoStack a
us'
EditField -> Mk (EditState a -> K i EditEvt) ()
forall (sp :: * -> * -> *) a i.
StreamProcIO sp =>
EditField -> Mk (EditState a -> sp i EditEvt) ()
storeField' EditField
field
(Int, Int) -> Mk (EditState a -> K i EditEvt) ()
forall a b c. (Int, Int) -> Mk (EditState a -> K b c) ()
setSize (Int, Int)
size
Mk (EditState a -> K i EditEvt) ()
forall a hi ho. Mk (EditState a -> K hi ho) ()
redraw
storeField' :: EditField -> Mk (EditState a -> sp i EditEvt) ()
storeField' EditField
field' =
do EditField -> Mk (EditState a -> sp i EditEvt) ()
forall k a. EditField -> Msc k (EditState a)
storeField EditField
field'
EditEvt -> Mk (EditState a -> sp i EditEvt) ()
forall (sp :: * -> * -> *) o i r.
StreamProcIO sp =>
o -> Msc (sp i o) r
putHighMs (InputMsg String -> EditEvt
EditChange (InputMsg String -> EditEvt) -> InputMsg String -> EditEvt
forall a b. (a -> b) -> a -> b
$ String -> InputMsg String
forall a. a -> InputMsg a
InputChange (String -> InputMsg String) -> String -> InputMsg String
forall a b. (a -> b) -> a -> b
$ EditField -> String
getField EditField
field')
puttext' :: (EditField -> o) -> Mk (EditState a -> sp i o) ()
puttext' EditField -> o
f = do EditField
field <- Ms (sp i o) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
o -> Mk (EditState a -> sp i o) ()
forall (sp :: * -> * -> *) o i r.
StreamProcIO sp =>
o -> Msc (sp i o) r
putHighMs (EditField -> o
f EditField
field)
puttext :: (EditField -> String) -> Mk (EditState a -> sp i EditEvt) ()
puttext EditField -> String
f = (EditField -> EditEvt) -> Mk (EditState a -> sp i EditEvt) ()
forall (sp :: * -> * -> *) o a i.
StreamProcIO sp =>
(EditField -> o) -> Mk (EditState a -> sp i o) ()
puttext' (String -> EditEvt
EditText (String -> EditEvt)
-> (EditField -> String) -> EditField -> EditEvt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditField -> String
f)
putCursor :: Mk (EditState a -> K i EditEvt) ()
putCursor =
do EditField
field <- Ms (K i EditEvt) (EditState a) EditField
forall k a. Ms k (EditState a) EditField
loadField
let lastpos :: (Int, Int)
lastpos = EditField -> (Int, Int)
getCurp EditField
field
EditEvt -> Mk (EditState a -> K i EditEvt) ()
forall (sp :: * -> * -> *) o i r.
StreamProcIO sp =>
o -> Msc (sp i o) r
putHighMs (Rect -> EditEvt
EditCursor (Rect -> EditEvt) -> Rect -> EditEvt
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Rect
Rect ((Int, Int) -> Point
line2p (Int, Int)
lastpos Point -> Point -> Point
`psub` Int -> Int -> Point
Point Int
xoffset Int
0)
(Int -> Int -> Point
Point Int
xoffset Int
lheight Point -> Point -> Point
`padd` Point
llmargin))
handleLow :: FResponse -> Mk (EditState a -> K a b) ()
handleLow FResponse
msg =
case FResponse
msg of
XEvt (Expose Rect
r Int
aft) -> Cont (K a b) Rect -> Ms (K a b) (EditState a) Rect
forall k r s. Cont k r -> Ms k s r
toMs (Bool -> Rect -> Int -> Cont (K a b) Rect
forall a b. Bool -> Rect -> Int -> (Rect -> K a b) -> K a b
maxExposeK Bool
False Rect
r Int
aft) Ms (K a b) (EditState a) Rect
-> (Rect -> Mk (EditState a -> K a b) ())
-> Mk (EditState a -> K a b) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rect -> Mk (EditState a -> K a b) ()
forall a hi ho. Rect -> Mk (EditState a -> K hi ho) ()
expose
XEvt (GraphicsExpose Rect
r Int
aft Int
_ Int
_) -> Cont (K a b) Rect -> Ms (K a b) (EditState a) Rect
forall k r s. Cont k r -> Ms k s r
toMs (Bool -> Rect -> Int -> Cont (K a b) Rect
forall a b. Bool -> Rect -> Int -> (Rect -> K a b) -> K a b
maxExposeK Bool
True Rect
r Int
aft) Ms (K a b) (EditState a) Rect
-> (Rect -> Mk (EditState a -> K a b) ())
-> Mk (EditState a -> K a b) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rect -> Mk (EditState a -> K a b) ()
forall a hi ho. Rect -> Mk (EditState a -> K hi ho) ()
expose
LEvt (LayoutSize Point
s) -> Point -> Mk (EditState a -> K a b) ()
forall k a. Point -> Msc k (EditState a)
storeSize Point
s
FResponse
_ -> Mk (EditState a -> K a b) ()
forall k s. Msc k s
nopMs
handleHigh :: EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
handleHigh EditCmd
cmd =
do case EditCmd
cmd of
EditShowCursor Bool
s -> Bool -> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall a hi ho. Bool -> Mk (EditState a -> K hi ho) ()
showCursor Bool
s
EditMove EditStop
estop Bool
issel -> Bool
-> EditStop
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall a hi ho. Bool -> EditStop -> Mk (EditState a -> K hi ho) ()
move Bool
issel EditStop
estop
EditReplace String
s -> String -> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall b.
String -> Mk (EditState (EditField, (Int, Int)) -> K b EditEvt) ()
replace' String
s
EditCmd
EditGetText -> (EditField -> String)
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall (sp :: * -> * -> *) a i.
StreamProcIO sp =>
(EditField -> String) -> Mk (EditState a -> sp i EditEvt) ()
puttext EditField -> String
getField
EditCmd
EditGetField -> (EditField -> EditEvt)
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall (sp :: * -> * -> *) o a i.
StreamProcIO sp =>
(EditField -> o) -> Mk (EditState a -> sp i o) ()
puttext' ((String, String, String) -> EditEvt
EditField ((String, String, String) -> EditEvt)
-> (EditField -> (String, String, String)) -> EditField -> EditEvt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditField -> (String, String, String)
getField')
EditCmd
EditGetSelection -> (EditField -> String)
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall (sp :: * -> * -> *) a i.
StreamProcIO sp =>
(EditField -> String) -> Mk (EditState a -> sp i EditEvt) ()
puttext EditField -> String
getSelection
EditCmd
EditUndo -> (UndoStack (EditField, (Int, Int))
-> Maybe
((EditField, (Int, Int)), UndoStack (EditField, (Int, Int))))
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall a i.
(UndoStack a -> Maybe ((EditField, (Int, Int)), UndoStack a))
-> Mk (EditState a -> K i EditEvt) ()
undoredo UndoStack (EditField, (Int, Int))
-> Maybe
((EditField, (Int, Int)), UndoStack (EditField, (Int, Int)))
forall a. UndoStack a -> Maybe (a, UndoStack a)
undo
EditCmd
EditRedo -> (UndoStack (EditField, (Int, Int))
-> Maybe
((EditField, (Int, Int)), UndoStack (EditField, (Int, Int))))
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall a i.
(UndoStack a -> Maybe ((EditField, (Int, Int)), UndoStack a))
-> Mk (EditState a -> K i EditEvt) ()
undoredo UndoStack (EditField, (Int, Int))
-> Maybe
((EditField, (Int, Int)), UndoStack (EditField, (Int, Int)))
forall a. UndoStack a -> Maybe (a, UndoStack a)
redo
Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall a i. Mk (EditState a -> K i EditEvt) ()
putCursor
EditField
field <- Ms (K hi EditEvt) (EditState (EditField, (Int, Int))) EditField
forall k a. Ms k (EditState a) EditField
loadField
let lastpos :: (Int, Int)
lastpos = EditField -> (Int, Int)
getCurp EditField
field
case EditCmd
cmd of
EditMove (EditLine EDirection
_) Bool
_ -> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall k s. Msc k s
nopMs
EditCmd
_ -> (Int, Int)
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
forall k a. (Int, Int) -> Msc k (EditState a)
storeLastpos (Int, Int)
lastpos
proc :: Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) b
proc = do (FResponse
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ())
-> (EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ())
-> Message FResponse EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
forall t1 p t2. (t1 -> p) -> (t2 -> p) -> Message t1 t2 -> p
message FResponse
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
forall a a b. FResponse -> Mk (EditState a -> K a b) ()
handleLow EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
forall hi.
EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K hi EditEvt) ()
handleHigh (Message FResponse EditCmd
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ())
-> Mk
(EditState (EditField, (Int, Int)) -> K EditCmd EditEvt)
(Message FResponse EditCmd)
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Mk
(EditState (EditField, (Int, Int)) -> K EditCmd EditEvt)
(Message FResponse EditCmd)
forall hi ho s. Ms (K hi ho) s (KEvent hi)
getKs
Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) b
proc
in EditState (EditField, (Int, Int))
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) Any
-> K EditCmd EditEvt
-> K EditCmd EditEvt
forall b1 a b2. b1 -> Mk (b1 -> a) b2 -> a -> a
stateK EditState (EditField, (Int, Int))
forall a. EditState a
initstate ((Int, Int)
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
forall a b c. (Int, Int) -> Mk (EditState a -> K b c) ()
setSize (Int
1,Int
0) Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) ()
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) Any
-> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) Any
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) Any
forall b.
Mk (EditState (EditField, (Int, Int)) -> K EditCmd EditEvt) b
proc) K EditCmd EditEvt
forall hi ho. K hi ho
nullK
minWidth :: Int
minWidth = Int
10
xoffset :: Int
xoffset = Int
2
llmargin :: Point
llmargin = Int -> Int -> Point
Point Int
2 Int
2
defaultuslimit :: Maybe a
defaultuslimit = Maybe a
forall a. Maybe a
Nothing
uslimit :: Maybe Int
uslimit = let ul :: Int
ul = String -> Int -> Int
forall p. (Read p, Show p) => String -> p -> p
argReadKey String
"undodepth" (-Int
1)
in if Int
ul Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 then Maybe Int
forall a. Maybe a
defaultuslimit else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ul
data EditState a = S { EditState a -> Bool
shocur :: Bool,
EditState a -> (Int, Int)
twidth :: (Int,Int),
EditState a -> UndoStack a
undostack :: UndoStack a,
EditState a -> EditField
field :: EditField,
EditState a -> Point
size :: Point,
EditState a -> (Int, Int)
lastpos :: (Int,Int)
}
initstate :: EditState a
initstate = Bool
-> (Int, Int)
-> UndoStack a
-> EditField
-> Point
-> (Int, Int)
-> EditState a
forall a.
Bool
-> (Int, Int)
-> UndoStack a
-> EditField
-> Point
-> (Int, Int)
-> EditState a
S Bool
False (Int
1,Int
0) (Maybe Int -> UndoStack a
forall a. Maybe Int -> UndoStack a
undoStack Maybe Int
uslimit) (String -> EditField
createField String
"") Point
origin (Int
0, Int
0)
loadShowCursor :: Ms k (EditState a) Bool
loadShowCursor = (EditState a -> Bool) -> Ms k (EditState a) Bool
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> Bool
forall a. EditState a -> Bool
shocur
loadTextWidth :: Ms k (EditState a) (Int, Int)
loadTextWidth = (EditState a -> (Int, Int)) -> Ms k (EditState a) (Int, Int)
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> (Int, Int)
forall a. EditState a -> (Int, Int)
twidth
loadUndoStack :: Ms k (EditState a) (UndoStack a)
loadUndoStack = (EditState a -> UndoStack a) -> Ms k (EditState a) (UndoStack a)
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> UndoStack a
forall a. EditState a -> UndoStack a
undostack
loadField :: Ms k (EditState a) EditField
loadField = (EditState a -> EditField) -> Ms k (EditState a) EditField
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> EditField
forall a. EditState a -> EditField
field
loadSize :: Ms k (EditState a) Point
loadSize = (EditState a -> Point) -> Ms k (EditState a) Point
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> Point
forall a. EditState a -> Point
size
loadLastpos :: Ms k (EditState a) (Int, Int)
loadLastpos = (EditState a -> (Int, Int)) -> Ms k (EditState a) (Int, Int)
forall s f k. (s -> f) -> Ms k s f
fieldMs EditState a -> (Int, Int)
forall a. EditState a -> (Int, Int)
lastpos
loadWidth :: Mk (EditState a -> k) Int
loadWidth = (Point -> Int)
-> Mk (EditState a -> k) Point -> Mk (EditState a -> k) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point -> Int
xcoord Mk (EditState a -> k) Point
forall k a. Ms k (EditState a) Point
loadSize
#define MODMS(lbl) ( \ lbl -> (modMs ( \ s -> s { lbl=lbl } )))
storeShowCursor :: Bool -> Msc k (EditState a)
storeShowCursor = MODMS(shocur)
storeTextWidth :: (Int, Int) -> Msc k (EditState a)
storeTextWidth = MODMS(twidth)
storeUndoStack :: UndoStack a -> Msc k (EditState a)
storeUndoStack = MODMS(undostack)
storeField :: EditField -> Msc k (EditState a)
storeField = MODMS(field)
storeSize :: Point -> Msc k (EditState a)
storeSize = MODMS(size)
storeLastpos :: (Int, Int) -> Msc k (EditState a)
storeLastpos = MODMS(lastpos)