{-# 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' = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word -> Int) -> Word -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Int
wordToInt :: (Word->Char)
ord' :: Char -> Word
ord' = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Char -> Int) -> Char -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
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 String -> [String] -> Bool
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\BS' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\DEL'
isBackSpace String
_ = Bool
False

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

isCtrl :: Char -> String -> Bool
isCtrl Char
c (Char
c':String
_) = Char
c' Char -> Char -> Bool
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 Modifiers -> t Modifiers -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Modifiers
mods then Word -> Char
chr' (Char -> Word
ord' Char
c0 Word -> Word -> Word
forall a. Bits a => a -> a -> a
`bitOr` Word
128) else Char
c0

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

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

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

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

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

showinputfield :: GCId
-> GCId
-> FontStructF (Array Char CharStruct)
-> ([a] -> String)
-> Bool
-> Field a
-> [FRequest]
showinputfield GCId
gc GCId
gcinv FontStructF (Array Char CharStruct)
font [a] -> String
show' = Bool -> Field a -> [FRequest]
showinputfield'
  where
    drimstr :: GCId -> Point -> String -> FRequest
drimstr = if (Char, Char) -> Char
forall a b. (a, b) -> b
snd (FontStructF (Array Char CharStruct) -> (Char, Char)
forall per_char. FontStructF per_char -> (Char, Char)
font_range FontStructF (Array Char CharStruct)
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

    showinputfield' :: Bool -> Field a -> [FRequest]
showinputfield' Bool
active Field a
field =
      let y :: Int
y = FontStructF (Array Char CharStruct) -> Int
forall per_char. FontStructF per_char -> Int
font_ascent FontStructF (Array Char CharStruct)
font Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
	  draw :: Int -> String -> [FRequest]
draw Int
x String
s = if String -> Bool
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 -> [a] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart p
gc' [a]
s0 (Int
x, [FRequest]
cmds) =
	      let s :: String
s = [a] -> String
show' [a]
s0
	      in  (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FontStructF (Array Char CharStruct) -> String -> Int
next_pos FontStructF (Array Char CharStruct)
font String
s, Int -> String -> [FRequest]
draw Int
x String
s [FRequest] -> [FRequest] -> [FRequest]
forall a. [a] -> [a] -> [a]
++ [FRequest]
cmds)
	  showcursor :: [a] -> (Int, [FRequest]) -> (Int, [FRequest])
showcursor [a]
s (Int
x1, [FRequest]
cmds) =
	      let (Int
x2, [FRequest]
cmds') = GCId -> [a] -> (Int, [FRequest]) -> (Int, [FRequest])
forall p. p -> [a] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart GCId
gc [a]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
1
						 (Int
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (FontStructF (Array Char CharStruct) -> Int
forall per_char. FontStructF per_char -> Int
linespace FontStructF (Array Char CharStruct)
font))]
		        else []
	      in  (Int
x2, [FRequest]
cmds' [FRequest] -> [FRequest] -> [FRequest]
forall a. [a] -> [a] -> [a]
++ [FRequest]
cmd)
      in  (Int, [FRequest]) -> [FRequest]
forall a b. (a, b) -> b
snd (([a] -> (Int, [FRequest]) -> (Int, [FRequest]))
-> ([a] -> (Int, [FRequest]) -> (Int, [FRequest]))
-> Field a
-> (Int, [FRequest])
-> (Int, [FRequest])
forall a b1 b2.
([a] -> b1 -> b2) -> ([a] -> b2 -> b1) -> Field a -> b1 -> b2
showField (GCId -> [a] -> (Int, [FRequest]) -> (Int, [FRequest])
forall p. p -> [a] -> (Int, [FRequest]) -> (Int, [FRequest])
showpart GCId
gc) [a] -> (Int, [FRequest]) -> (Int, [FRequest])
showcursor Field a
field (Int
hmargin, []))

createField' :: Int -> [a] -> Field a
createField' Int
pos [a]
s =
  if Int
posInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
  then [a] -> Field a
forall a. [a] -> Field a
createField [a]
s
  else ([a], [a]) -> Field a
forall a. ([a], [a]) -> Field a
createField2 (Int -> [a] -> ([a], [a])
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 =
    Int
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. Int -> K a b -> K a b
setFontCursor Int
152 (K (Either (SelEvt String) (Either (Customiser StringF) String))
   (Either (SelCmd String) (InputMsg String))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$
    XCommand
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall i o. XCommand -> K i o -> K i o
xcommandK ([WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
bw]) (K (Either (SelEvt String) (Either (Customiser StringF) String))
   (Either (SelCmd String) (InputMsg String))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$
    ColorSpec
-> (Pixel
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a i o.
(Show a, ColorGen a) =>
a -> (Pixel -> K i o) -> K i o
changeGetBackPixel ColorSpec
bgcolor ((Pixel
  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (Pixel
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \Pixel
bg ->
    ColorSpec
-> (Pixel
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a (f :: * -> * -> *) i o.
(ColorGen a, FudgetIO f, Show a) =>
a -> (Pixel -> f i o) -> f i o
convColorK ColorSpec
fgcolor ((Pixel
  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (Pixel
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \Pixel
fg ->
    FontSpec
-> (FontData
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a (f :: * -> * -> *) i o.
(FontGen a, FudgetIO f, Show a) =>
a -> (FontData -> f i o) -> f i o
convFontK FontSpec
fontspec ((FontData
  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (FontData
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \ FontData
fd ->
    FontData
-> (FontStructF (Array Char CharStruct)
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall p.
FontData -> (FontStructF (Array Char CharStruct) -> p) -> p
fontdata2struct FontData
fd ((FontStructF (Array Char CharStruct)
  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (FontStructF (Array Char CharStruct)
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \ FontStructF (Array Char CharStruct)
font ->
    GCId
-> [GCAttributes Pixel FontId]
-> (GCId
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 (FontStructF (Array Char CharStruct) -> FontId
forall per_char. FontStructF per_char -> FontId
font_id FontStructF (Array Char CharStruct)
font),
                      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
  -> K (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (GCId
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \GCId
drawGC ->
    GCId
-> [GCAttributes Pixel FontId]
-> (GCId
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 (Either (SelEvt String) (Either (Customiser StringF) String))
       (Either (SelCmd String) (InputMsg String)))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> (GCId
    -> K (Either (SelEvt String) (Either (Customiser StringF) String))
         (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall a b. (a -> b) -> a -> b
$ \GCId
invertGC ->
    let drawit :: Field Char -> Bool -> [Message FRequest b]
drawit Field Char
field Bool
active = (FRequest -> Message FRequest b)
-> [FRequest] -> [Message FRequest b]
forall a b. (a -> b) -> [a] -> [b]
map FRequest -> Message FRequest b
forall a b. a -> Message a b
Low (XCommand -> FRequest
XCmd XCommand
ClearWindow FRequest -> [FRequest] -> [FRequest]
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 = GCId
-> GCId
-> FontStructF (Array Char CharStruct)
-> (String -> String)
-> Bool
-> Field Char
-> [FRequest]
forall a.
GCId
-> GCId
-> FontStructF (Array Char CharStruct)
-> ([a] -> String)
-> Bool
-> Field a
-> [FRequest]
showinputfield GCId
drawGC GCId
invertGC FontStructF (Array Char CharStruct)
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 =
	         [KCommand (Either (SelCmd String) (InputMsg String))]
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall b a. [KCommand b] -> K a b -> K a b
putsK (Field Char
-> Bool -> [KCommand (Either (SelCmd String) (InputMsg String))]
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 = [KCommand (Either (SelCmd String) (InputMsg String))]
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall b a. [KCommand b] -> K a b -> K a b
putsK (Field Char
-> Bool -> [KCommand (Either (SelCmd String) (InputMsg String))]
forall b. Field Char -> Bool -> [Message FRequest b]
drawit Field Char
field Bool
a) (K (Either (SelEvt String) (Either (Customiser StringF) String))
   (Either (SelCmd String) (InputMsg String))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 = [KCommand (Either (SelCmd String) (InputMsg String))]
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall b a. [KCommand b] -> K a b -> K a b
putsK (Field Char
-> Bool -> [KCommand (Either (SelCmd String) (InputMsg String))]
forall b. Field Char -> Bool -> [Message FRequest b]
drawit Field Char
f Bool
a [KCommand (Either (SelCmd String) (InputMsg String))]
-> [KCommand (Either (SelCmd String) (InputMsg String))]
-> [KCommand (Either (SelCmd String) (InputMsg String))]
forall a. [a] -> [a] -> [a]
++ [Either (SelCmd String) (InputMsg String)
-> KCommand (Either (SelCmd String) (InputMsg String))
forall a b. b -> Message a b
High (InputMsg String -> Either (SelCmd String) (InputMsg String)
forall a b. b -> Either a b
Right InputMsg String
msg)]) (K (Either (SelEvt String) (Either (Customiser StringF) String))
   (Either (SelCmd String) (InputMsg String))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 = Field Char -> String
forall a. Field a -> [a]
getField Field Char
f
		  in  Point
-> String
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 (String -> InputMsg String
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 (String -> String -> InputMsg String
forall a. String -> a -> InputMsg a
InputDone String
key (Field Char -> String
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 (String -> String -> InputMsg String
forall a. String -> a -> InputMsg a
InputDone String
inputLeaveKey (Field Char -> String
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 = KCommand (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (Either (SelCmd String) (InputMsg String)
-> KCommand (Either (SelCmd String) (InputMsg String))
forall a b. b -> Message a b
High (SelCmd String -> Either (SelCmd String) (InputMsg String)
forall a b. a -> Either a b
Left SelCmd String
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 = KCommand (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (Either (SelCmd String) (InputMsg String)
-> KCommand (Either (SelCmd String) (InputMsg String))
forall a b. b -> Message a b
High (SelCmd String -> Either (SelCmd String) (InputMsg String)
forall a b. a -> Either a b
Left (String -> SelCmd String
forall a. a -> SelCmd a
Sel (Field Char -> String
forall a. Field a -> [a]
getField Field Char
field)))) K (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
nochange
	   in Cont
  (K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String)))
  (KEvent
     (Either (SelEvt String) (Either (Customiser StringF) String)))
forall hi ho. Cont (K hi ho) (KEvent hi)
getK Cont
  (K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String)))
  (KEvent
     (Either (SelEvt String) (Either (Customiser StringF) String)))
-> Cont
     (K (Either (SelEvt String) (Either (Customiser StringF) String))
        (Either (SelCmd String) (InputMsg String)))
     (KEvent
        (Either (SelEvt String) (Either (Customiser StringF) String)))
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 (Field Char -> Char -> Field Char
forall a. Field a -> a -> Field a
insertItem Field Char
field Char
c)
			   where c :: Char
c = [Modifiers] -> Char -> Char
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 (String -> Field Char
forall a. [a] -> Field a
createField (Field Char -> String
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 (Field Char -> Field Char
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 (Field Char -> Field Char
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 (Field Char -> Field Char
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 (String -> Field Char
forall a. [a] -> Field a
createField String
"")
			  | Bool
otherwise ->
			       case [Modifiers] -> String -> Maybe (Field Char -> Field Char)
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 (FontStructF (Array Char CharStruct)
-> Point -> Field Char -> Field Char
placecursor FontStructF (Array Char CharStruct)
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
newtextString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=Field Char -> String
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 (String -> Field Char
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 (Field Char -> String -> Field Char
forall a. Field a -> [a] -> Field a
insertItemsSelected Field Char
field String
s)
		   where s :: String
s = (Char -> Bool) -> String -> String
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' = StringF -> Int
forall xxx. HasBorderWidth xxx => xxx -> Int
getBorderWidth StringF
ps
		initsize' :: String
initsize' = String
txt' --getInitSize ps -- hmm !!
		sizing' :: Sizing
sizing' = StringF -> Sizing
forall xxx. HasSizing xxx => xxx -> Sizing
getSizing StringF
ps
		bgcolor' :: ColorSpec
bgcolor' = StringF -> ColorSpec
forall xxx. HasBgColorSpec xxx => xxx -> ColorSpec
getBgColorSpec StringF
ps
		fgcolor' :: ColorSpec
fgcolor' = StringF -> ColorSpec
forall xxx. HasFgColorSpec xxx => xxx -> ColorSpec
getFgColorSpec StringF
ps
		fontspec' :: FontSpec
fontspec' = StringF -> 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' = Field Char -> String
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
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
hmargin) (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
vmargin) Point -> Point -> Point
forall a. Num a => a -> a -> a
+ FontStructF (Array Char CharStruct) -> String -> Point
string_box_size FontStructF (Array Char CharStruct)
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 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
curSize then Point -> K hi ho -> K hi ho
forall hi ho. Point -> K hi ho -> K hi ho
putlayoutlims Point
nsize else K hi ho -> K hi ho
forall a. a -> a
id
	putlayoutlims :: Point -> K hi ho -> K hi ho
putlayoutlims Point
size' =
	   KCommand ho -> K hi ho -> K hi ho
forall ho hi. KCommand ho -> K hi ho -> K hi ho
putK (FRequest -> KCommand ho
forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size' Bool
False Bool
True)))
    in Point
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
forall hi ho. Point -> K hi ho -> K hi ho
putlayoutlims Point
size (K (Either (SelEvt String) (Either (Customiser StringF) String))
   (Either (SelCmd String) (InputMsg String))
 -> K (Either (SelEvt String) (Either (Customiser StringF) String))
      (Either (SelCmd String) (InputMsg String)))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 (Int -> String -> Field Char
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 =
   F (Either (SelEvt String) (Either (Customiser StringF) String))
  (Either (SelCmd String) (InputMsg String))
-> F (SelCmd String) (SelEvt String)
-> F (Either (Customiser StringF) String) (InputMsg String)
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 (XCommand -> FRequest) -> XCommand -> FRequest
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 = [FRequest]
-> K (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
-> F (Either (SelEvt String) (Either (Customiser StringF) String))
     (Either (SelCmd String) (InputMsg String))
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 String -> String
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 = StringF -> Int
forall xxx. HasBorderWidth xxx => xxx -> Int
getBorderWidth StringF
ps
    bg :: ColorSpec
bg = StringF -> ColorSpec
forall xxx. HasBgColorSpec xxx => xxx -> ColorSpec
getBgColorSpec StringF
ps
    fg :: ColorSpec
fg = StringF -> ColorSpec
forall xxx. HasFgColorSpec xxx => xxx -> ColorSpec
getFgColorSpec StringF
ps
    font :: FontSpec
font = StringF -> 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
    --initsize = "xxxxx"
    initsize :: String
initsize = StringF -> String
getInitSize StringF
ps
    sizing :: Sizing
sizing = StringF -> 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 F (Either (Customiser StringF) String) (InputMsg String)
-> (String -> Either (Customiser StringF) String)
-> F String (InputMsg String)
forall c d e. F c d -> (e -> c) -> F e d
>=^< String -> Either (Customiser StringF) String
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' String -> String
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' ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'*'))

oldIntF :: Int -> InF Int Int
oldIntF :: Int -> InF Int Int
oldIntF Int
default' =
    (String -> Int) -> InputMsg String -> InputMsg Int
forall t a. (t -> a) -> InputMsg t -> InputMsg a
mapInp String -> Int
forall a. Read a => String -> a
read (InputMsg String -> InputMsg Int)
-> F String (InputMsg String) -> F String (InputMsg Int)
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 String -> String
forall a. a -> a
id (Int -> String
forall a. Show a => a -> String
show Int
default') F String (InputMsg Int) -> (Int -> String) -> InF Int Int
forall c d e. F c d -> (e -> c) -> F e d
>=^<
    Int -> String
forall a. Show a => a -> String
show

stringfont :: FontSpec
stringfont = String -> FontSpec
forall a. (Show a, FontGen a) => a -> FontSpec
fontSpec (String -> String -> String
argKey String
"inputfont" String
defaultFont)
inputbg :: ColorSpec
inputbg = [String] -> ColorSpec
forall a. (Show a, ColorGen a) => a -> ColorSpec
colorSpec (String -> [String] -> [String]
argKeyList String
"stringbg" [String
inputBg])
inputfg :: ColorSpec
inputfg = [String] -> ColorSpec
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
cChar -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>Char
'\xff' Bool -> Bool -> Bool
|| Char -> Bool
isPrint Char
c