{-# LANGUAGE CPP #-}
module StringF(
  stringF'',StringF,
  {-HasBorderWidth(..),HasAllowedChar(..),HasShowString(..),-}
  getAllowedChar,setAllowedChar,getShowString,setShowString,
  setInitStringSize,
  getCursorPos,setCursorPos,getInitString,setInitString,
  generalStringF, oldIntF, oldPasswdF, oldStringF, bdStringF, oldGeneralStringF
  ) where
import BgF(changeGetBackPixel)
--import Color
import Command
import DrawInWindow
import CompOps((>=^<), (>^=<))
--import Utils(bitand)
import HbcWord
import Cursor
import Defaults(defaultFont, inputFg, inputBg, metaKey)
import CmdLineEnv(argKey, argKeyList)
import Dlayout(windowF)
import Event
import Font(split_string,font_ascent,next_pos,linespace,font_id,string_box_size,font_range)
import Fudget
--import FudgetIO
import FRequest
import Xcommand
import Gc
import Xtypes
import Geometry(Point(..), pP, rR,pmax)
import LayoutRequest(plainLayout,LayoutResponse(..))
--import LoadFont
--import Message(Message(..))
import NullF
--import Spops
import StringEdit
import InputMsg(InputMsg(..),mapInp,inputLeaveKey)
import InputF(InF(..))
import SelectionF
import Loops(loopThroughRightF)
import Sizing
#ifdef __GLASGOW_HASKELL__
import FDefaults hiding (setInitSize,getInitSize,getInitSizeMaybe)
#else
-- Some versions of HBC fail if you mention a constructor class in an import spec.
--import FDefaults hiding (HasInitSize)
import FDefaults(cust,getpar,getparMaybe,HasBorderWidth(..),HasSizing(..),HasBgColorSpec(..),HasFgColorSpec(..),HasFontSpec(..),Customiser(..),PF(..))
#endif
import Data.Char(isPrint,isDigit)
import GCAttrs --(ColorSpec,colorSpec,convColorK) -- + instances

default(Int)

-- chr/ord are defined in *some* versions of the library module Char...
chr' :: Word -> Char
chr' = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
wordToInt :: (Word->Char)
ord' :: Char -> Word
ord' = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum :: (Char->Word)


#include "defaults.h"

newtype StringF = Pars [Pars]

parameter(AllowedChar)
parameter(ShowString)
parameter(CursorPos)
parameter(InitString)

parameter_instance(BorderWidth,StringF)
parameter_instance(FgColorSpec,StringF)
parameter_instance(BgColorSpec,StringF)
parameter_instance(FontSpec,StringF)
parameter_instance(Sizing,StringF)
--parameter_instance(InitSize,StringF) -- StringF has wrong kind for this
parameter(InitSize)

setInitStringSize :: String -> Customiser StringF
setInitStringSize = String -> Customiser StringF
setInitSize -- avoid name clash

data Pars
  = BorderWidth Int
  | FgColorSpec ColorSpec
  | BgColorSpec ColorSpec
  | FontSpec FontSpec
  | AllowedChar (Char->Bool)
  | ShowString (String->String)
  | InitSize String
  | Sizing Sizing
  | CursorPos Int -- puts cursor after the nth character
  | InitString String

isTerminator :: String -> Bool
isTerminator String
key = String
key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Escape", String
"Return", String
"KP_Enter", String
"Tab", String
"Up", String
"Down"]

isBackSpace :: String -> Bool
isBackSpace (Char
c : String
_) = Char
c forall a. Eq a => a -> a -> Bool
== Char
'\BS' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\DEL'
isBackSpace String
_ = Bool
False

ctrl :: Char -> Char
ctrl Char
c = Word -> Char
chr' (forall {a}. Bits a => a -> a -> a
bitAnd (Char -> Word
ord' Char
c) (Word
65535forall a. Num a => a -> a -> a
-Word
96))

isCtrl :: Char -> String -> Bool
isCtrl Char
c (Char
c':String
_) = Char
c' forall a. Eq a => a -> a -> Bool
== Char -> Char
ctrl Char
c
isCtrl Char
_ String
_      = Bool
False

isKill :: String -> Bool
isKill = Char -> String -> Bool
isCtrl Char
'u'

modchar :: t Modifiers -> Char -> Char
modchar t Modifiers
mods Char
c0 = if Modifiers
metaKey forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Modifiers
mods then Word -> Char
chr' (Char -> Word
ord' Char
c0 forall {a}. Bits a => a -> a -> a
`bitOr` Word
128) else Char
c0

cursorBindings' :: [(([Modifiers], String), Field a -> Field a)]
cursorBindings' =
  [(([], String
"Left"), forall {a}. Field a -> Field a
moveCursorLeft),
   (([], String
"Right"), forall {a}. Field a -> Field a
moveCursorRight),
   (([], String
"Home"), forall {a}. Field a -> Field a
moveCursorHome),
-- (([], "Up"), moveCursorHome),
   (([], String
"End"), forall {a}. Field a -> Field a
moveCursorEnd),
-- (([], "Down"), moveCursorEnd),
--   (([Shift],"Control"), moveCursorHome), -- ???
--   (([Shift],"Control"), moveCursorEnd), -- ???
   (([Modifiers
Shift],String
"Left"), forall {a}. Field a -> Field a
extendCursorLeft),
   (([Modifiers
Shift],String
"Right"), forall {a}. Field a -> Field a
extendCursorRight),
   (([Modifiers
Shift],String
"Home"), forall {a}. Field a -> Field a
extendCursorHome),
   (([Modifiers
Shift],String
"Up"), forall {a}. Field a -> Field a
extendCursorHome),
   (([Modifiers
Shift],String
"End"), forall {a}. Field a -> Field a
extendCursorEnd),
   (([Modifiers
Shift],String
"Down"), forall {a}. Field a -> Field a
extendCursorEnd)]
   forall a. [a] -> [a] -> [a]
++ forall {a}. [(([Modifiers], String), Field a -> Field a)]
emacsBindings

emacsBindings :: [(([Modifiers], String), Field a -> Field a)]
emacsBindings = 
  [(([Modifiers
Control], String
"b"), forall {a}. Field a -> Field a
moveCursorLeft),
   (([Modifiers
Control], String
"f"), forall {a}. Field a -> Field a
moveCursorRight),
   (([Modifiers
Control], String
"e"), forall {a}. Field a -> Field a
moveCursorEnd),
   (([Modifiers
Control], String
"a"), forall {a}. Field a -> Field a
moveCursorHome)]

cursorKey' :: [Modifiers] -> String -> Maybe (Field a -> Field a)
cursorKey' [Modifiers]
mods String
key = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
<=Modifiers
Mod5) [Modifiers]
mods,String
key) forall {a}. [(([Modifiers], String), Field a -> Field a)]
cursorBindings'

hmargin :: Int
hmargin = Int
3
vmargin :: Int
vmargin = Int
2

placecursor :: FontStruct -> Point -> Field Char -> Field Char
placecursor FontStruct
font (Point Int
x Int
_) Field Char
field =
    case forall {a}. Field a -> [a]
getField Field Char
field of
      [] -> Field Char
field
      String
cs -> let (String
lcs, String
rcs, Int
_) = FontStruct -> String -> Int -> (String, String, Int)
split_string FontStruct
font String
cs (Int
x forall a. Num a => a -> a -> a
- Int
hmargin)
            in  forall {a}. ([a], [a]) -> Field a
createField2 (String
lcs, String
rcs)

showinputfield :: GCId
-> GCId
-> FontStruct
-> ([a1] -> String)
-> Bool
-> Field a1
-> [FRequest]
showinputfield GCId
gc GCId
gcinv FontStruct
font [a1] -> String
show' = Bool -> Field a1 -> [FRequest]
showinputfield'
  where
    drimstr :: GCId -> Point -> String -> FRequest
drimstr = if forall a b. (a, b) -> b
snd (forall {per_char}. FontStructF per_char -> (Char, Char)
font_range FontStruct
font) forall a. Ord a => a -> a -> Bool
> Char
'\xff'
              then GCId -> Point -> String -> FRequest
wDrawImageString16
	      else GCId -> Point -> String -> FRequest
wDrawImageString

    showinputfield' :: Bool -> Field a1 -> [FRequest]
showinputfield' Bool
active Field a1
field =
      let y :: Int
y = forall per_char. FontStructF per_char -> Int
font_ascent FontStruct
font forall a. Num a => a -> a -> a
+ Int
1
	  draw :: Int -> String -> [FRequest]
draw Int
x String
s = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then [] else [GCId -> Point -> String -> FRequest
drimstr GCId
gc (Int -> Int -> Point
pP Int
x Int
y) String
s]
	  showpart :: p -> [a1] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart p
gc' [a1]
s0 (Int
x, [FRequest]
cmds) =
	      let s :: String
s = [a1] -> String
show' [a1]
s0
	      in  (Int
x forall a. Num a => a -> a -> a
+ FontStruct -> String -> Int
next_pos FontStruct
font String
s, Int -> String -> [FRequest]
draw Int
x String
s forall a. [a] -> [a] -> [a]
++ [FRequest]
cmds)
	  showcursor :: [a1] -> (Int, [FRequest]) -> (Int, [FRequest])
showcursor [a1]
s (Int
x1, [FRequest]
cmds) =
	      let (Int
x2, [FRequest]
cmds') = forall {p}. p -> [a1] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart GCId
gc [a1]
s (Int
x1, [FRequest]
cmds)
		  cmd :: [FRequest]
cmd = if Bool
active
			then [GCId -> Rect -> FRequest
wFillRectangle GCId
gcinv
					     (Int -> Int -> Int -> Int -> Rect
rR (Int
x1 forall a. Num a => a -> a -> a
- Int
1) Int
1
						 (Int
x2 forall a. Num a => a -> a -> a
- Int
x1 forall a. Num a => a -> a -> a
+ Int
1) (forall per_char. FontStructF per_char -> Int
linespace FontStruct
font))]
		        else []
	      in  (Int
x2, [FRequest]
cmds' forall a. [a] -> [a] -> [a]
++ [FRequest]
cmd)
      in  forall a b. (a, b) -> b
snd (forall {a1} {a2} {b}.
([a1] -> a2 -> b) -> ([a1] -> b -> a2) -> Field a1 -> a2 -> b
showField (forall {p}. p -> [a1] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart GCId
gc) [a1] -> (Int, [FRequest]) -> (Int, [FRequest])
showcursor Field a1
field (Int
hmargin, []))

createField' :: Int -> [a] -> Field a
createField' Int
pos [a]
s =
  if Int
posforall a. Ord a => a -> a -> Bool
<Int
0
  then forall {a}. [a] -> Field a
createField [a]
s
  else forall {a}. ([a], [a]) -> Field a
createField2 (forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [a]
s)

stringK :: Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringK Int
bw String
initsize Sizing
sizing ColorSpec
bgcolor ColorSpec
fgcolor FontSpec
fontspec Char -> Bool
allowedchar String -> String
show' Int
cursor String
defaultText Bool
active =
    forall a b. Int -> K a b -> K a b
setFontCursor Int
152 forall a b. (a -> b) -> a -> b
$
    forall {i} {o}. XCommand -> K i o -> K i o
xcommandK ([WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
bw]) forall a b. (a -> b) -> a -> b
$
    forall {a} {i} {o}.
(Show a, ColorGen a) =>
a -> (Pixel -> K i o) -> K i o
changeGetBackPixel ColorSpec
bgcolor forall a b. (a -> b) -> a -> b
$ \Pixel
bg ->
    forall {a} {f :: * -> * -> *} {i} {o}.
(ColorGen a, FudgetIO f, Show a) =>
a -> (Pixel -> f i o) -> f i o
convColorK ColorSpec
fgcolor forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
    forall {a} {f :: * -> * -> *} {i} {o}.
(FontGen a, FudgetIO f, Show a) =>
a -> (FontData -> f i o) -> f i o
convFontK FontSpec
fontspec forall a b. (a -> b) -> a -> b
$ \ FontData
fd ->
    forall {t}. FontData -> (FontStruct -> t) -> t
fontdata2struct FontData
fd forall a b. (a -> b) -> a -> b
$ \ FontStruct
font ->
    forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC [forall a b. GCFunction -> GCAttributes a b
GCFunction GCFunction
GXcopy, forall a b. b -> GCAttributes a b
GCFont (forall per_char. FontStructF per_char -> FontId
font_id FontStruct
font),
                      forall a b. a -> GCAttributes a b
GCForeground Pixel
fg, forall a b. a -> GCAttributes a b
GCBackground Pixel
bg] forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
    forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC (forall {b}. Pixel -> Pixel -> [GCAttributes Pixel b]
invertColorGCattrs Pixel
bg Pixel
fg) forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
    let drawit :: Field Char -> Bool -> [Message FRequest b]
drawit Field Char
field Bool
active = forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Message a b
Low (XCommand -> FRequest
XCmd XCommand
ClearWindow forall a. a -> [a] -> [a]
: [FRequest]
drawcmds)
          where drawcmds :: [FRequest]
drawcmds = Bool -> Field Char -> [FRequest]
shinpf Bool
active Field Char
field
	shinpf :: Bool -> Field Char -> [FRequest]
shinpf = forall {a1}.
GCId
-> GCId
-> FontStruct
-> ([a1] -> String)
-> Bool
-> Field a1
-> [FRequest]
showinputfield GCId
drawGC GCId
invertGC FontStruct
font String -> String
show'
	stringproc :: Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size' Field Char
field Bool
active =
	   let redraw :: Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
redraw Field Char
f =
	         forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Field Char -> Bool -> [Message FRequest b]
drawit Field Char
f Bool
active) (Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size' Field Char
f Bool
active)
	       nochange :: K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange = Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size' Field Char
field Bool
active
	       newsize :: Point
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
newsize Point
s = Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
s Field Char
field Bool
active
	       changeactive :: Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
changeactive Bool
a = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Field Char -> Bool -> [Message FRequest b]
drawit Field Char
field Bool
a) forall a b. (a -> b) -> a -> b
$
	                        Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size' Field Char
field Bool
a
	       emit :: InputMsg String
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emit InputMsg String
msg Field Char
f Bool
a = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. Field Char -> Bool -> [Message FRequest b]
drawit Field Char
f Bool
a forall a. [a] -> [a] -> [a]
++ [forall a b. b -> Message a b
High (forall a b. b -> Either a b
Right InputMsg String
msg)]) forall a b. (a -> b) -> a -> b
$
	                      Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size' Field Char
f Bool
a
	       emitchange :: Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitchange Field Char
f =
	          let gf :: String
gf = forall {a}. Field a -> [a]
getField Field Char
f
		  in  forall {hi} {ho}. Point -> String -> K hi ho -> K hi ho
updlayout Point
size' String
gf (InputMsg String
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emit (forall a. a -> InputMsg a
InputChange String
gf) Field Char
f Bool
active)
	       emitdone :: String
-> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitdone String
key Field Char
f = InputMsg String
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emit (forall a. String -> a -> InputMsg a
InputDone String
key (forall {a}. Field a -> [a]
getField Field Char
f)) Field Char
f Bool
active
	       emitleave :: K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
emitleave =
	         InputMsg String
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emit (forall a. String -> a -> InputMsg a
InputDone String
inputLeaveKey (forall {a}. Field a -> [a]
getField Field Char
field)) Field Char
field Bool
False
	       paste :: K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
paste = forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left forall a. SelCmd a
PasteSel)) K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
	       copy :: K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
copy = forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left (forall a. a -> SelCmd a
Sel (forall {a}. Field a -> [a]
getField Field Char
field)))) K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
	   in forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ \KEvent
  (Either (SelEvt String) (Either (Customiser StringF) String))
msg ->
	      case KEvent
  (Either (SelEvt String) (Either (Customiser StringF) String))
msg of
	        Low (XEvt XEvent
event) ->
		  case XEvent
event of
	            Expose Rect
_ Int
_ -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
redraw Field Char
field
		    KeyEvent Int
_ Point
_ Point
_ [Modifiers]
mods Pressed
Pressed KeyCode
_ String
key String
ascii ->
		      case String
ascii of
			Char
c0 : String
_ | Char -> Bool
allowedchar Char
c -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec (forall {a}. Field a -> a -> Field a
insertItem Field Char
field Char
c)
			   where c :: Char
c = forall {t :: * -> *}. Foldable t => t Modifiers -> Char -> Char
modchar [Modifiers]
mods Char
c0
			String
_ | String -> Bool
isTerminator String
key ->
			       String
-> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitdone String
key (forall {a}. [a] -> Field a
createField (forall {a}. Field a -> [a]
getField Field Char
field))
			  | String -> Bool
isBackSpace String
ascii -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec (forall {a}. Field a -> Field a
deleteItemLeft Field Char
field)
			  | Char -> String -> Bool
isCtrl Char
'd' String
ascii  -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec (forall {a}. Field a -> Field a
deleteItemRight Field Char
field)
			  | Char -> String -> Bool
isCtrl Char
'k' String
ascii  -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec (forall {a}. Field a -> Field a
deleteToEnd Field Char
field)
			  | Char -> String -> Bool
isCtrl Char
'y' String
ascii  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
paste
			  | Char -> String -> Bool
isCtrl Char
'c' String
ascii  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
copy
			  | Char -> String -> Bool
isCtrl Char
'w' String
ascii  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
copy -- should acutally be cut
			  | String -> Bool
isKill     String
ascii  -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec (forall {a}. [a] -> Field a
createField String
"")
			  | Bool
otherwise ->
			       case forall {a}. [Modifiers] -> String -> Maybe (Field a -> Field a)
cursorKey' [Modifiers]
mods String
key of
				 Just Field Char -> Field Char
ed -> Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
redraw (Field Char -> Field Char
ed Field Char
field)
				 Maybe (Field Char -> Field Char)
_ -> case String
key of
					String
"SunPaste" -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
paste
					String
"SunCopy" -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
copy
					String
_ -> --putK (Low (Bell 0)) $
					     K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
		       where ec :: Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
ec = Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitchange
	            ButtonEvent {pos :: XEvent -> Point
pos=Point
p, button :: XEvent -> Button
button=Button Int
1} ->
		      Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
redraw (FontStruct -> Point -> Field Char -> Field Char
placecursor FontStruct
font Point
p Field Char
field)
	            ButtonEvent {button :: XEvent -> Button
button=Button Int
2} -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
paste
		    FocusIn  {} -> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
changeactive Bool
True
		    FocusOut {} -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
emitleave
                    XEvent
_ -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
		Low (LEvt (LayoutSize Point
nsize)) -> Point
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
newsize Point
nsize
		High (Right (Right String
newtext)) ->
		   if String
newtextforall a. Eq a => a -> a -> Bool
/=forall {a}. Field a -> [a]
getField Field Char
field
		   then Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitchange (forall {a}. [a] -> Field a
createField String
newtext)
		   --else updlayout size' newtext (redraw (createField newtext))
		   else K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
		High (Right (Left Customiser StringF
customiser)) ->
		  Customiser StringF
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
reconfigure Customiser StringF
customiser Field Char
field Bool
active
		High (Left (SelNotify String
cs)) ->
		     Field Char
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
emitchange (forall {a}. Field a -> [a] -> Field a
insertItemsSelected Field Char
field String
s)
		   where s :: String
s = forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
allowedchar String
cs
		KEvent
  (Either (SelEvt String) (Either (Customiser StringF) String))
_ -> K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange

	reconfigure :: Customiser StringF
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
reconfigure Customiser StringF
pmod Field Char
field Bool
active =
	    -- !! unload fonts, free GCs & colors...
	    Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringK Int
bw' String
initsize' Sizing
sizing' ColorSpec
bgcolor' ColorSpec
fgcolor' FontSpec
fontspec' Char -> Bool
allowed' String -> String
show'' Int
cursor' String
txt' Bool
active
	    -- !!! Bad: active will be reset to False.
	    -- !! A new layout request will be output (useful if font changed).
	  where ps :: StringF
ps = Customiser StringF
pmod ([Pars] -> StringF
Pars [Int -> Pars
BorderWidth Int
bw,
                                 ColorSpec -> Pars
BgColorSpec ColorSpec
bgcolor,
				 ColorSpec -> Pars
FgColorSpec ColorSpec
fgcolor,
				 FontSpec -> Pars
FontSpec FontSpec
fontspec,
				 (Char -> Bool) -> Pars
AllowedChar Char -> Bool
allowedchar,
				 (String -> String) -> Pars
ShowString String -> String
show',
				 Int -> Pars
CursorPos (-Int
1), -- !!
				 String -> Pars
InitSize String
initsize,
				 Sizing -> Pars
Sizing Sizing
sizing])
		bw' :: Int
bw' = forall xxx. HasBorderWidth xxx => xxx -> Int
getBorderWidth StringF
ps
		initsize' :: String
initsize' = String
txt' --getInitSize ps -- hmm !!
		sizing' :: Sizing
sizing' = forall xxx. HasSizing xxx => xxx -> Sizing
getSizing StringF
ps
		bgcolor' :: ColorSpec
bgcolor' = forall xxx. HasBgColorSpec xxx => xxx -> ColorSpec
getBgColorSpec StringF
ps
		fgcolor' :: ColorSpec
fgcolor' = forall xxx. HasFgColorSpec xxx => xxx -> ColorSpec
getFgColorSpec StringF
ps
		fontspec' :: FontSpec
fontspec' = forall xxx. HasFontSpec xxx => xxx -> FontSpec
getFontSpec StringF
ps
		allowed' :: Char -> Bool
allowed' = StringF -> Char -> Bool
getAllowedChar StringF
ps
		show'' :: String -> String
show'' = StringF -> String -> String
getShowString StringF
ps
		txt' :: String
txt' = forall {a}. Field a -> [a]
getField Field Char
field
		cursor' :: Int
cursor' = StringF -> Int
getCursorPos StringF
ps

	sizetext :: String -> Point
sizetext String
text = Int -> Int -> Point
pP (Int
2forall a. Num a => a -> a -> a
*Int
hmargin) (Int
2forall a. Num a => a -> a -> a
*Int
vmargin) forall a. Num a => a -> a -> a
+ FontStruct -> String -> Point
string_box_size FontStruct
font String
text
	size :: Point
size = Point -> Point -> Point
pmax (String -> Point
sizetext String
defaultText) (String -> Point
sizetext String
initsize)
	updlayout :: Point -> String -> K hi ho -> K hi ho
updlayout Point
curSize String
gf =
	   let reqSize :: Point
reqSize = String -> Point
sizetext String
gf
	       nsize :: Point
nsize = Sizing -> Point -> Point -> Point
newSize Sizing
sizing Point
curSize Point
reqSize
	   in if Point
nsize forall a. Eq a => a -> a -> Bool
/= Point
curSize then forall {hi} {ho}. Point -> K hi ho -> K hi ho
putlayoutlims Point
nsize else forall a. a -> a
id
	putlayoutlims :: Point -> K hi ho -> K hi ho
putlayoutlims Point
size' =
	   forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size' Bool
False Bool
True)))
    in forall {hi} {ho}. Point -> K hi ho -> K hi ho
putlayoutlims Point
size forall a b. (a -> b) -> a -> b
$
       Point
-> Field Char
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringproc Point
size (forall {a}. Int -> [a] -> Field a
createField' Int
cursor String
defaultText) Bool
active

generalStringF :: Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> F (Either (Customiser StringF) String) (InputMsg String)
generalStringF Int
bw String
initsize Sizing
sizing ColorSpec
bg ColorSpec
fg FontSpec
fontspec Char -> Bool
allowedchar String -> String
show' Int
cursor String
txt =
   forall a b c d. F (Either a b) (Either c d) -> F c a -> F b d
loopThroughRightF F (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
winF F (SelCmd String) (SelEvt String)
selectionF
  where
    eventmask :: [EventMask]
eventmask = [EventMask
ExposureMask, EventMask
KeyPressMask, EventMask
ButtonPressMask,
		 EventMask
EnterWindowMask, EventMask
LeaveWindowMask -- to be removed
		 ]
    startcmds :: [FRequest]
startcmds = [XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ 
                 [WindowAttributes] -> XCommand
ChangeWindowAttributes [Gravity -> WindowAttributes
CWBitGravity Gravity
NorthWestGravity,
					 [EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask
					 {-,CWBackingStore Always-}]
		]
    winF :: F (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
winF = forall a b. [FRequest] -> K a b -> F a b
windowF [FRequest]
startcmds 
	           (Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> Bool
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
stringK Int
bw String
initsize Sizing
sizing ColorSpec
bg ColorSpec
fg FontSpec
fontspec
		            Char -> Bool
allowedchar String -> String
show' Int
cursor String
txt Bool
False)

stringF'' :: (Customiser StringF) -> PF StringF String (InputMsg String)
stringF'' :: Customiser StringF
-> F (Either (Customiser StringF) String) (InputMsg String)
stringF'' Customiser StringF
pmod = Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> F (Either (Customiser StringF) String) (InputMsg String)
generalStringF Int
bw String
initsize Sizing
sizing ColorSpec
bg ColorSpec
fg FontSpec
font Char -> Bool
allowed String -> String
show Int
cursor String
initstring
  where
    ps :: StringF
ps = Customiser StringF
pmod ([Pars] -> StringF
Pars [Int -> Pars
BorderWidth Int
1,
                     ColorSpec -> Pars
BgColorSpec ColorSpec
inputbg,
		     ColorSpec -> Pars
FgColorSpec ColorSpec
inputfg,
		     FontSpec -> Pars
FontSpec FontSpec
stringfont,
		     (Char -> Bool) -> Pars
AllowedChar Char -> Bool
isPrint',
		     (String -> String) -> Pars
ShowString forall a. a -> a
id,
		     String -> Pars
InitSize String
"xxxxx",
		     Sizing -> Pars
Sizing Sizing
Growing,
		     Int -> Pars
CursorPos (-Int
1),
		     String -> Pars
InitString String
""])
    bw :: Int
bw = forall xxx. HasBorderWidth xxx => xxx -> Int
getBorderWidth StringF
ps
    bg :: ColorSpec
bg = forall xxx. HasBgColorSpec xxx => xxx -> ColorSpec
getBgColorSpec StringF
ps
    fg :: ColorSpec
fg = forall xxx. HasFgColorSpec xxx => xxx -> ColorSpec
getFgColorSpec StringF
ps
    font :: FontSpec
font = forall xxx. HasFontSpec xxx => xxx -> FontSpec
getFontSpec StringF
ps
    allowed :: Char -> Bool
allowed = StringF -> Char -> Bool
getAllowedChar StringF
ps
    show :: String -> String
show = StringF -> String -> String
getShowString StringF
ps
    --initsize = "xxxxx"
    initsize :: String
initsize = StringF -> String
getInitSize StringF
ps
    sizing :: Sizing
sizing = forall xxx. HasSizing xxx => xxx -> Sizing
getSizing StringF
ps
    cursor :: Int
cursor = StringF -> Int
getCursorPos StringF
ps
    initstring :: String
initstring = StringF -> String
getInitString StringF
ps


oldGeneralStringF :: Int
-> Sizing
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> String
-> F String (InputMsg String)
oldGeneralStringF Int
bw Sizing
sizing FontSpec
font Char -> Bool
allowed String -> String
show String
txt =
  Int
-> String
-> Sizing
-> ColorSpec
-> ColorSpec
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> Int
-> String
-> F (Either (Customiser StringF) String) (InputMsg String)
generalStringF Int
bw String
"xxxxx" Sizing
sizing ColorSpec
inputbg ColorSpec
inputfg FontSpec
font Char -> Bool
allowed String -> String
show (-Int
1) String
txt forall c d e. F c d -> (e -> c) -> F e d
>=^< forall a b. b -> Either a b
Right

bdStringF :: Int -> Sizing -> FontSpec -> String -> F String (InputMsg String)
bdStringF Int
bw Sizing
dyn FontSpec
font = Int
-> Sizing
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> String
-> F String (InputMsg String)
oldGeneralStringF Int
bw Sizing
dyn FontSpec
font Char -> Bool
isPrint' forall a. a -> a
id

oldStringF :: String -> InF String String
oldStringF :: String -> F String (InputMsg String)
oldStringF = Int -> Sizing -> FontSpec -> String -> F String (InputMsg String)
bdStringF Int
1 Sizing
Growing FontSpec
stringfont

oldPasswdF :: String -> InF String String
oldPasswdF :: String -> F String (InputMsg String)
oldPasswdF = Int
-> Sizing
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> String
-> F String (InputMsg String)
oldGeneralStringF Int
1 Sizing
Static FontSpec
stringfont Char -> Bool
isPrint' (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Char
'*'))

oldIntF :: Int -> InF Int Int
oldIntF :: Int -> InF Int Int
oldIntF Int
default' =
    forall {t} {a}. (t -> a) -> InputMsg t -> InputMsg a
mapInp forall a. Read a => String -> a
read forall a b e. (a -> b) -> F e a -> F e b
>^=<
    Int
-> Sizing
-> FontSpec
-> (Char -> Bool)
-> (String -> String)
-> String
-> F String (InputMsg String)
oldGeneralStringF Int
1 Sizing
Static FontSpec
stringfont Char -> Bool
isDigit forall a. a -> a
id (forall a. Show a => a -> String
show Int
default') forall c d e. F c d -> (e -> c) -> F e d
>=^<
    forall a. Show a => a -> String
show

stringfont :: FontSpec
stringfont = forall {a}. (Show a, FontGen a) => a -> FontSpec
fontSpec (String -> String -> String
argKey String
"inputfont" String
defaultFont)
inputbg :: ColorSpec
inputbg = forall {a}. (Show a, ColorGen a) => a -> ColorSpec
colorSpec (String -> [String] -> [String]
argKeyList String
"stringbg" [String
inputBg])
inputfg :: ColorSpec
inputfg = forall {a}. (Show a, ColorGen a) => a -> ColorSpec
colorSpec (String -> [String] -> [String]
argKeyList String
"stringfg" [String
inputFg])

-- Workaround limitations of HBC's Char.isPrint to allow Unicode input.
isPrint' :: Char -> Bool
isPrint' Char
c = Char
cforall a. Ord a => a -> a -> Bool
>Char
'\xff' Bool -> Bool -> Bool
|| Char -> Bool
isPrint Char
c