{-# LANGUAGE CPP #-}
module TextF(textF,textF',textF'',TextF,
	     TextRequest(..)) where
import Fudget
import FudgetIO
import FRequest
import NullF
import Utils
import Geometry
import Xtypes
import Event
import Command
import XDraw
import Dlayout
import DoubleClickF
import BgF
--import Color
--import EitherUtils(mapfilter)
import Data.Maybe(mapMaybe)
import Message(message) --Message(..),
import Font
--import LoadFont
import Gc
import InputMsg
import LayoutRequest
import Alignment(aLeft) --Alignment(..),
import Defaults(defaultFont,bgColor,fgColor)
import Sizing
import FDefaults
import GCAttrs --(ColorSpec,convColorK,colorSpec)
import ListRequest(ListRequest(..),listEnd)
#include "../defaults/defaults.h"

default(Int) -- mostly for Hugs


#ifndef __HBC__
#define fromInt fromIntegral
#endif

type TextRequest = ListRequest String

newtype TextF = Pars [Pars]

data Pars
  = BorderWidth Int
  | FgColorSpec ColorSpec
  | BgColorSpec ColorSpec
  | FontSpec FontSpec
  | Align Alignment
  | Margin Int
  | InitText [String]
--  | InitSize String
  | Stretchable (Bool,Bool)
  | Sizing Sizing

parameter_instance(BorderWidth,TextF)
parameter_instance(FgColorSpec,TextF)
parameter_instance(BgColorSpec,TextF)
parameter_instance(FontSpec,TextF)
parameter_instance(Align,TextF)
parameter_instance(Margin,TextF)
parameter_instance(InitText,TextF)
--parameter_instance(InitSize,TextF)
parameter_instance(Sizing,TextF)
parameter_instance(Stretchable,TextF)

textF :: F TextRequest (InputMsg (Int, FontName))
textF = Customiser TextF -> F TextRequest (InputMsg (Int, FontName))
textF' forall a. Customiser a
standard
textF' :: Customiser TextF -> F TextRequest (InputMsg (Int, FontName))
textF' Customiser TextF
pm = forall p a b. PF p a b -> F a b
noPF forall a b. (a -> b) -> a -> b
$ Customiser TextF -> PF TextF TextRequest (InputMsg (Int, FontName))
textF'' Customiser TextF
pm

textF'' :: Customiser TextF ->
           PF TextF TextRequest (InputMsg (Int, String))
textF'' :: Customiser TextF -> PF TextF TextRequest (InputMsg (Int, FontName))
textF'' Customiser TextF
pmod =
  let ps :: TextF
      ps :: TextF
ps = Customiser TextF
pmod ([Pars] -> TextF
Pars [Int -> Pars
BorderWidth Int
0,
                       ColorSpec -> Pars
FgColorSpec ColorSpec
textfg,
		       ColorSpec -> Pars
BgColorSpec ColorSpec
textbg,
		       Int -> Pars
Margin Int
2,
		       Alignment -> Pars
Align Alignment
aLeft,
		       [FontName] -> Pars
InitText [],--InitSize "",
		       (Bool, Bool) -> Pars
Stretchable (Bool
False,Bool
False),
		       Sizing -> Pars
Sizing Sizing
Dynamic,
		       FontSpec -> Pars
FontSpec (forall {a}. (Show a, FontGen a) => a -> FontSpec
fontSpec FontName
defaultFont)])
      bw :: Int
bw = forall xxx. HasBorderWidth xxx => xxx -> Int
getBorderWidth TextF
ps
      fg :: ColorSpec
fg = forall xxx. HasFgColorSpec xxx => xxx -> ColorSpec
getFgColorSpec TextF
ps
      bg :: ColorSpec
bg = forall xxx. HasBgColorSpec xxx => xxx -> ColorSpec
getBgColorSpec TextF
ps
      font :: FontSpec
font = forall xxx. HasFontSpec xxx => xxx -> FontSpec
getFontSpec TextF
ps
      init :: [FontName]
init = forall xxx. HasInitText xxx => xxx -> [FontName]
getInitText TextF
ps
      minstr :: FontName
minstr = FontName
"" --getInitSize ps
      margin :: Int
margin = forall xxx. HasMargin xxx => xxx -> Int
getMargin TextF
ps
      align :: Alignment
align = forall xxx. HasAlign xxx => xxx -> Alignment
getAlign TextF
ps
      sizing :: Sizing
sizing = forall xxx. HasSizing xxx => xxx -> Sizing
getSizing TextF
ps
      stretch :: (Bool, Bool)
stretch = forall xxx. HasStretchable xxx => xxx -> (Bool, Bool)
getStretchable TextF
ps

      eventmask :: [EventMask]
eventmask = [EventMask
ExposureMask, EventMask
ButtonPressMask]
      startcmds :: [FRequest]
startcmds = forall a b. (a -> b) -> [a] -> [b]
map XCommand -> FRequest
XCmd 
                  [[WindowChanges] -> XCommand
ConfigureWindow [Int -> WindowChanges
CWBorderWidth Int
bw],
  		   [WindowAttributes] -> XCommand
ChangeWindowAttributes
		     [[EventMask] -> WindowAttributes
CWEventMask [EventMask]
eventmask
		      ,Gravity -> WindowAttributes
CWBitGravity (Alignment -> Gravity
horizAlignGravity Alignment
align)
		      ,PixmapId -> WindowAttributes
CWBackPixmap PixmapId
none -- elim flicker caused by XClearArea
		      ]]
  in forall a b. Int -> F a b -> F a b
doubleClickF Int
doubleClickTime forall a b. (a -> b) -> a -> b
$
     forall a b. [FRequest] -> K a b -> F a b
windowF [FRequest]
startcmds forall a b. (a -> b) -> a -> b
$ forall {a} {a} {a} {p}.
(ColorGen a, ColorGen a, FontGen a, Show a, Show a, Show a,
 RealFrac p) =>
a
-> a
-> a
-> (Bool, Bool)
-> p
-> Sizing
-> Int
-> FontName
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK0 ColorSpec
bg ColorSpec
fg FontSpec
font (Bool, Bool)
stretch Alignment
align Sizing
sizing Int
margin FontName
minstr [FontName]
init


textK0 :: a
-> a
-> a
-> (Bool, Bool)
-> p
-> Sizing
-> Int
-> FontName
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK0 a
bg a
fg a
font (Bool
flexh,Bool
flexv) p
align Sizing
sizing Int
margin FontName
minstr [FontName]
init =
    forall {a} {i} {o}.
(Show a, ColorGen a) =>
a -> (Pixel -> K i o) -> K i o
changeGetBackPixel a
bg forall a b. (a -> b) -> a -> b
$ \ Pixel
bgcol ->
    forall {a} {f :: * -> * -> *} {i} {o}.
(ColorGen a, FudgetIO f, Show a) =>
a -> (Pixel -> f i o) -> f i o
convColorK a
fg forall a b. (a -> b) -> a -> b
$ \ Pixel
fgcol ->
    --allocNamedColorPixel defaultColormap fg $ \ fgcol ->
    forall {a} {f :: * -> * -> *} {i} {o}.
(FontGen a, FudgetIO f, Show a) =>
a -> (FontData -> f i o) -> f i o
convFontK a
font 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
fs ->
    forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
rootGC [forall a b. b -> GCAttributes a b
GCFont (forall per_char. FontStructF per_char -> FontId
font_id FontStruct
fs),
  		      forall a b. a -> GCAttributes a b
GCForeground Pixel
fgcol,
		      forall a b. a -> GCAttributes a b
GCBackground Pixel
bgcol] forall a b. (a -> b) -> a -> b
$ \GCId
gc ->
    forall {f :: * -> * -> *} {hi} {ho}.
FudgetIO f =>
GCId -> GCAttributeList -> (GCId -> f hi ho) -> f hi ho
wCreateGC GCId
gc     [forall a b. a -> GCAttributes a b
GCForeground Pixel
bgcol,
		      forall a b. a -> GCAttributes a b
GCBackground Pixel
fgcol] forall a b. (a -> b) -> a -> b
$ \GCId
gcinv ->
    let minw :: Int
minw = FontStruct -> FontName -> Int
next_pos FontStruct
fs FontName
minstr
    in forall {p}.
RealFrac p =>
Pixel
-> GCId
-> GCId
-> FontStruct
-> Bool
-> Bool
-> p
-> Sizing
-> Int
-> Int
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK1 Pixel
bgcol GCId
gc GCId
gcinv FontStruct
fs (Bool -> Bool
not Bool
flexh) (Bool -> Bool
not Bool
flexv) p
align Sizing
sizing Int
margin Int
minw [FontName]
init

textK1 :: Pixel
-> GCId
-> GCId
-> FontStruct
-> Bool
-> Bool
-> p
-> Sizing
-> Int
-> Int
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK1 Pixel
bgcol GCId
gc GCId
gcinv FontStruct
fs Bool
fh Bool
fv p
align Sizing
sizing Int
margin Int
minw =
    forall {p}.
Point
-> p
-> [Int]
-> [(FontName, Int)]
-> Int
-> Int
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
replaceTextK Point
origin Point
origin [] [] Int
0 Int
listEnd
  where
    ll :: Point -> Message FRequest b
ll Point
size = forall a b. a -> Message a b
Low (LayoutRequest -> FRequest
layoutRequestCmd (Point -> Bool -> Bool -> LayoutRequest
plainLayout Point
size Bool
fh Bool
fv))
    ls :: Int
ls = forall {per_char}. FontStructF per_char -> Int
linespace FontStruct
fs
    base :: Int
base = forall {per_char}. FontStructF per_char -> Int
font_ascent FontStruct
fs forall a. Num a => a -> a -> a
+ Int
margin
    margsize :: Point
margsize = Int -> Point
diag (Int
2forall a. Num a => a -> a -> a
*Int
margin)

    measure :: [FontName] -> [(FontName, Int)]
measure = forall a b. (a -> b) -> [a] -> [b]
map (forall {t} {b}. (t -> b) -> t -> (t, b)
pairwith (FontStruct -> FontName -> Int
next_pos FontStruct
fs))
    txtwidth :: [(a, Int)] -> Int
txtwidth [(a, Int)]
mtxt = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
1forall a. a -> [a] -> [a]
:Int
minwforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Int)]
mtxt)
                         -- 0 width not allowed for windows

    drimstr :: Point -> FontName -> DrawCommand
drimstr = if forall a b. (a, b) -> b
snd (forall {per_char}. FontStructF per_char -> (Char, Char)
font_range FontStruct
fs) forall a. Ord a => a -> a -> Bool
> Char
'\xff'
              then Point -> FontName -> DrawCommand
DrawImageString16
	      else Point -> FontName -> DrawCommand
DrawImageString

    txtsize :: [(a, Int)] -> Point
txtsize [(a, Int)]
mtxt =
      let width :: Int
width = forall {a}. [(a, Int)] -> Int
txtwidth [(a, Int)]
mtxt
	  height :: Int
height = forall a. Ord a => a -> a -> a
max Int
1 (Int
lsforall a. Num a => a -> a -> a
*forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Int)]
mtxt)  -- 0 height not allowed for windows
      in Int -> Int -> Point
Point Int
width Int
height

    replaceTextK :: Point
-> p
-> [Int]
-> [(FontName, Int)]
-> Int
-> Int
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
replaceTextK winsize :: Point
winsize@(Point Int
winwidth Int
winheight) p
size [Int]
sel [(FontName, Int)]
mtxt Int
dfrom Int
dcnt [FontName]
newtxt=
      let lines :: Int
lines     = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FontName, Int)]
mtxt
	  from :: Int
from      = forall a. Ord a => a -> a -> a
min Int
lines (if Int
dfromforall a. Eq a => a -> a -> Bool
==Int
listEnd then Int
lines else Int
dfrom)
	  after :: Int
after     = Int
linesforall a. Num a => a -> a -> a
-Int
from
	  cnt :: Int
cnt       = forall a. Ord a => a -> a -> a
min Int
after (if Int
dcntforall a. Eq a => a -> a -> Bool
==Int
listEnd then Int
after else Int
dcnt)
	  newcnt :: Int
newcnt    = forall (t :: * -> *) a. Foldable t => t a -> Int
length [FontName]
newtxt
	  diff :: Int
diff      = Int
newcntforall a. Num a => a -> a -> a
-Int
cnt
	  scrollsize :: Int
scrollsize= Int
afterforall a. Num a => a -> a -> a
-Int
cnt
	  newlines :: Int
newlines  = Int
linesforall a. Num a => a -> a -> a
+Int
diff
	  sel' :: [Int]
sel'      = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Int -> Maybe Int
reloc [Int]
sel
	  reloc :: Int -> Maybe Int
reloc Int
n   = if Int
nforall a. Ord a => a -> a -> Bool
<Int
from then forall a. a -> Maybe a
Just Int
n
		      else if Int
nforall a. Ord a => a -> a -> Bool
<Int
fromforall a. Num a => a -> a -> a
+Int
cnt then forall a. Maybe a
Nothing
		      else forall a. a -> Maybe a
Just (Int
nforall a. Num a => a -> a -> a
+Int
diff)
	  mtxt' :: [(FontName, Int)]
mtxt'     = forall a. Int -> [a] -> [a]
take Int
from [(FontName, Int)]
mtxt forall a. [a] -> [a] -> [a]
++ [FontName] -> [(FontName, Int)]
measure [FontName]
newtxt forall a. [a] -> [a] -> [a]
++ 
		      (if Int
scrollsizeforall a. Ord a => a -> a -> Bool
>Int
0 then forall a. Int -> [a] -> [a]
drop (Int
fromforall a. Num a => a -> a -> a
+Int
cnt) [(FontName, Int)]
mtxt else [])
	  newwidth :: Int
newwidth  = forall {a}. [(a, Int)] -> Int
txtwidth [(FontName, Int)]
mtxt'
	  newsize :: Point
newsize   = Int -> Int -> Point
Point Int
newwidth (Int
lsforall a. Num a => a -> a -> a
*Int
newlines)
	  llcmd :: [Message FRequest b]
llcmd     = let realwinsize :: Point
realwinsize@(Point Int
w Int
h) = Point
winsizeforall a. Num a => a -> a -> a
+Int -> Point
diag Int
margin
	                  winsize' :: Point
winsize'@(Point Int
w' Int
h') = Point
newsize forall a. Num a => a -> a -> a
+Point
margsize
	                  change :: Bool
change =
			    Point
winsizeforall a. Eq a => a -> a -> Bool
==Point
origin Bool -> Bool -> Bool
||
			    Sizing -> Point -> Point -> Point
newSize Sizing
sizing Point
realwinsize Point
winsize'forall a. Eq a => a -> a -> Bool
/=Point
realwinsize
	              in if Bool
change
		      then [forall {b}. Point -> Message FRequest b
ll (Point
newsize forall a. Num a => a -> a -> a
+ Point
margsize)]
		      else []
	  --width     = xcoord size
	  drawwidth :: Int
drawwidth = forall a. Ord a => a -> a -> a
max Int
newwidth (Int
winwidthforall a. Num a => a -> a -> a
-Int
margin)
		       -- !! always scrolls/clears the full width of the window
	  scrollrect :: Rect
scrollrect= Int -> Int -> Int -> Int -> Rect
rR Int
margin (Int
marginforall a. Num a => a -> a -> a
+Int
lsforall a. Num a => a -> a -> a
*(Int
fromforall a. Num a => a -> a -> a
+Int
cnt))
	                 Int
drawwidth (Int
lsforall a. Num a => a -> a -> a
*Int
scrollsize)
	  scrolldest :: Point
scrolldest= Int -> Int -> Point
Point Int
margin (Int
marginforall a. Num a => a -> a -> a
+Int
lsforall a. Num a => a -> a -> a
*(Int
fromforall a. Num a => a -> a -> a
+Int
newcnt))
	  scrollcmd :: [Message FRequest b]
scrollcmd = if Int
scrollsizeforall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& Int
diffforall a. Eq a => a -> a -> Bool
/=Int
0
		      then [forall a b. a -> Message a b
Low (GCId -> DrawCommand -> FRequest
wDraw GCId
gc forall a b. (a -> b) -> a -> b
$ Drawable -> Rect -> Point -> DrawCommand
CopyArea Drawable
MyWindow Rect
scrollrect Point
scrolldest)]
		      else []
	  drawrect :: Rect
drawrect  = Int -> Int -> Int -> Int -> Rect
rR Int
margin (Int
marginforall a. Num a => a -> a -> a
+Int
lsforall a. Num a => a -> a -> a
*Int
from) (Int
drawwidthforall a. Num a => a -> a -> a
+Int
margin) (Int
lsforall a. Num a => a -> a -> a
*Int
newcnt)
	                 -- add margin to width to erase text in the margin
			 -- when the text is wider than the window.
	  belowrect :: Rect
belowrect = Int -> Int -> Int -> Int -> Rect
rR Int
margin (Int
marginforall a. Num a => a -> a -> a
+Int
lsforall a. Num a => a -> a -> a
*Int
newlines) Int
drawwidth (-Int
lsforall a. Num a => a -> a -> a
*Int
diff)
	  clearcmd :: [Message FRequest b]
clearcmd  = (if Int
newcntforall a. Ord a => a -> a -> Bool
>Int
0
		       then let vrect :: Rect
vrect = Rect -> Point -> Rect
growrect Rect
drawrect (Int -> Int -> Point
pP Int
5 Int
5) -- !! tmp fix
		           in forall {b}. Rect -> Bool -> [Message FRequest b]
clearArea Rect
drawrect Bool
Trueforall a. [a] -> [a] -> [a]
++
		              [forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd (Rect -> LayoutMessage
layoutMakeVisible Rect
vrect))]
		       else [])forall a. [a] -> [a] -> [a]
++
		       (if Int
diffforall a. Ord a => a -> a -> Bool
<Int
0
		        then [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ Rect -> Bool -> XCommand
ClearArea Rect
belowrect Bool
False]
			     -- Needed because of margin and other things
			     -- that cause the window to be taller than the
			     -- text.
			     -- clearcmd must be done after scrollcmd !!
			else [])
	  clearArea :: Rect -> Bool -> [Message FRequest b]
clearArea Rect
r Bool
e = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> Message a b
Low forall b c a. (b -> c) -> (a -> b) -> a -> c
. XCommand -> FRequest
XCmd) 
	                  [[WindowAttributes] -> XCommand
ChangeWindowAttributes [PixmapId -> WindowAttributes
CWBackPixmap PixmapId
none],
	                   Rect -> Bool -> XCommand
ClearArea Rect
r Bool
e,
			   [WindowAttributes] -> XCommand
ChangeWindowAttributes [Pixel -> WindowAttributes
CWBackPixel Pixel
bgcol]]
			-- Some backround may be lost if the windows becomes
			-- obscured while the BackPixmap is none !!!
      in if Int
diffforall a. Ord a => a -> a -> Bool
>Int
0
	 then forall {b} {a}. [KCommand b] -> (Point -> K a b) -> K a b
resizeK forall {b}. [Message FRequest b]
llcmd forall a b. (a -> b) -> a -> b
$ \ Point
newwinsize ->
	      forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. [Message FRequest b]
scrollcmdforall a. [a] -> [a] -> [a]
++forall {b}. [Message FRequest b]
clearcmd) forall a b. (a -> b) -> a -> b
$
	      Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK (Point
newwinsize forall a. Num a => a -> a -> a
- Int -> Point
diag Int
margin) Point
newsize [Int]
sel' [(FontName, Int)]
mtxt'
	 else forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. [Message FRequest b]
scrollcmdforall a. [a] -> [a] -> [a]
++forall {b}. [Message FRequest b]
clearcmdforall a. [a] -> [a] -> [a]
++forall {b}. [Message FRequest b]
llcmd) forall a b. (a -> b) -> a -> b
$
	      Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK Point
winsize Point
newsize [Int]
sel' [(FontName, Int)]
mtxt'

    textK :: Size -> Size -> [Int] -> [(String,Int)] ->
             PK TextF TextRequest (InputMsg (Int,String))
    textK :: Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK winsize :: Point
winsize@(Point Int
winwidth Int
_) Point
size [Int]
sel [(FontName, Int)]
mtxt =
       -- winsize is the size of the window excluding the right & bottom margins
	forall {hi} {ho}. Cont (K hi ho) (KEvent hi)
getK forall a b. (a -> b) -> a -> b
$ forall {t1} {t2} {t3}.
(t1 -> t2) -> (t3 -> t2) -> Message t1 t3 -> t2
message FResponse
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
lowK (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {p}.
p
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
paramChangeK TextRequest
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textRequestK)
      where
        same :: K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same = Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK Point
winsize Point
size [Int]
sel [(FontName, Int)]
mtxt
	textRequestK :: TextRequest
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textRequestK TextRequest
msg =
	    case TextRequest
msg of
	      ReplaceItems Int
dfrom Int
dcnt [FontName]
newtxt ->
		forall {p}.
Point
-> p
-> [Int]
-> [(FontName, Int)]
-> Int
-> Int
-> [FontName]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
replaceTextK Point
winsize Point
size [Int]
sel [(FontName, Int)]
mtxt Int
dfrom Int
dcnt [FontName]
newtxt
	      HighlightItems [Int]
sel' ->
		forall {t :: * -> *} {a} {b}. Foldable t => t Int -> K a b -> K a b
changeHighlightK [Int]
sel' forall a b. (a -> b) -> a -> b
$
		Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK Point
winsize Point
size [Int]
sel' [(FontName, Int)]
mtxt
	      PickItem Int
n -> ((Int, FontName) -> InputMsg (Int, FontName))
-> Int
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
output forall {a}. a -> InputMsg a
inputMsg Int
n
	      TextRequest
_ -> K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same
	lowK :: FResponse
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
lowK FResponse
event =
	    case FResponse
event of
	      XEvt (ButtonEvent {button :: XEvent -> Button
button=Button Int
1,pos :: XEvent -> Point
pos=Point Int
_ Int
y, type' :: XEvent -> Pressed
type'=Pressed
press}) ->
		let l :: Int
l=Int
y forall a. Integral a => a -> a -> a
`quot` Int
ls
		    pressmsg :: a -> InputMsg a
pressmsg = case Pressed
press of
				 MultiClick Int
2 -> forall {a}. a -> InputMsg a
inputMsg
				 Pressed
_ -> forall {a}. a -> InputMsg a
InputChange
		in ((Int, FontName) -> InputMsg (Int, FontName))
-> Int
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
output forall {a}. a -> InputMsg a
pressmsg Int
l
	      XEvt (Expose {rect :: XEvent -> Rect
rect=Rect
r}) ->
		forall {a} {b}. Rect -> K a b -> K a b
redrawTextK Rect
r forall a b. (a -> b) -> a -> b
$
		K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same
	      XEvt (GraphicsExpose {rect :: XEvent -> Rect
rect=Rect
r}) ->
		forall {a} {b}. Rect -> K a b -> K a b
redrawTextK Rect
r forall a b. (a -> b) -> a -> b
$
		K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same
	      LEvt (LayoutSize Point
newwinsize) ->
	        Point
-> Point
-> [Int]
-> [(FontName, Int)]
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
textK (Point
newwinsize forall a. Num a => a -> a -> a
- Int -> Point
diag Int
margin) Point
size [Int]
sel [(FontName, Int)]
mtxt
	      FResponse
_ -> K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same
	paramChangeK :: p
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
paramChangeK p
_ = K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same -- !!! Dynamic customisation not implemented yet
        output :: ((Int, FontName) -> InputMsg (Int, FontName))
-> Int
-> K (Either (Customiser TextF) TextRequest)
     (InputMsg (Int, FontName))
output (Int, FontName) -> InputMsg (Int, FontName)
pressmsg Int
l = (if Int
lforall a. Ord a => a -> a -> Bool
>=Int
0 Bool -> Bool -> Bool
&& Int
lforall a. Ord a => a -> a -> Bool
<forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FontName, Int)]
mtxt
	                     then forall {ho} {hi}. KCommand ho -> K hi ho -> K hi ho
putK (forall a b. b -> Message a b
High ((Int, FontName) -> InputMsg (Int, FontName)
pressmsg (Int
l,forall a b. (a, b) -> a
fst([(FontName, Int)]
mtxtforall a. [a] -> Int -> a
!!Int
l))))
			     else forall a. Customiser a
id) forall a b. (a -> b) -> a -> b
$ K (Either (Customiser TextF) TextRequest)
  (InputMsg (Int, FontName))
same

	changeHighlightK :: t Int -> K a b -> K a b
changeHighlightK t Int
sel' =
	    forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK (forall {b}. [Message FRequest b]
mkvisforall a. [a] -> [a] -> [a]
++[forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ [(GCId, [DrawCommand])] -> FRequest
wDrawMany (forall a b. (a -> b) -> [a] -> [b]
map (Int, (FontName, Int)) -> (GCId, [DrawCommand])
draw [(Int, (FontName, Int))]
changes)])
	  where
	    changed :: Int -> Bool
changed Int
n = (Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
sel) forall a. Eq a => a -> a -> Bool
/= (Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Int
sel')
	    nmtxt :: [(Int, (FontName, Int))]
nmtxt = forall a. Int -> [a] -> [(Int, a)]
number Int
0 [(FontName, Int)]
mtxt
	    changes :: [(Int, (FontName, Int))]
changes = [(Int, (FontName, Int))
l | l :: (Int, (FontName, Int))
l@(Int
n,(FontName, Int)
_)<-[(Int, (FontName, Int))]
nmtxt, Int -> Bool
changed Int
n]
	    selected :: [(Int, (FontName, Int))]
selected = [(Int, (FontName, Int))
l | l :: (Int, (FontName, Int))
l@(Int
n,(FontName, Int)
_)<-[(Int, (FontName, Int))]
nmtxt, Int
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Int
sel']
	    draw :: (Int, (FontName, Int)) -> (GCId, [DrawCommand])
draw (Int
n,(FontName
s,Int
w)) = (forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> GCId
dgc t Int
sel' Int
n,[Point -> FontName -> DrawCommand
drimstr (Int -> Int -> Point
Point (Int -> Int
x0 Int
w) (Int
baseforall a. Num a => a -> a -> a
+Int
nforall a. Num a => a -> a -> a
*Int
ls)) FontName
s])
	    mkvis :: [Message FRequest b]
mkvis =
	      case ([(Int, (FontName, Int))]
selected,forall a. [a] -> a
last [(Int, (FontName, Int))]
selected) of -- needs lazy evalution!
		([],(Int, (FontName, Int))
_) -> []
		((Int
n1,(FontName
_,Int
w1)):[(Int, (FontName, Int))]
_,(Int
n2,(FontName
_,Int
w2))) ->
		    [forall a b. a -> Message a b
Low (LayoutMessage -> FRequest
LCmd (Rect -> LayoutMessage
layoutMakeVisible Rect
vrect))]
		  where vrect :: Rect
vrect = Int -> Int -> Int -> Int -> Rect
rR Int
x1 Int
y1 (Int
x2forall a. Num a => a -> a -> a
-Int
x1forall a. Num a => a -> a -> a
+Int
5) (Int
y2forall a. Num a => a -> a -> a
-Int
y1forall a. Num a => a -> a -> a
+Int
5)
                        x1 :: Int
x1 = forall a. Ord a => a -> a -> a
min (Int -> Int
x0 Int
w1) (Int -> Int
x0 Int
w2) -- !!! Should use min/max
			x2 :: Int
x2 = forall a. Ord a => a -> a -> a
max (Int -> Int
x0 Int
w1) (Int -> Int
x0 Int
w2) -- !!! of all changes.
			y1 :: Int
y1 = Int
n1forall a. Num a => a -> a -> a
*Int
ls
			y2 :: Int
y2 = (Int
n2forall a. Num a => a -> a -> a
+Int
1)forall a. Num a => a -> a -> a
*Int
ls

	redrawTextK :: Rect -> K a b -> K a b
redrawTextK r :: Rect
r@(Rect (Point Int
x Int
y) (Point Int
w Int
h)) =
	  let first :: Int
first = (forall a. Ord a => a -> a -> a
max Int
0 (Int
yforall a. Num a => a -> a -> a
-Int
margin)) forall a. Integral a => a -> a -> a
`quot` Int
ls
	      last :: Int
last = (Int
yforall a. Num a => a -> a -> a
+Int
hforall a. Num a => a -> a -> a
-Int
1) forall a. Integral a => a -> a -> a
`quot` Int
ls
	      lines :: [(Int, (FontName, Int))]
lines = forall a. Int -> [a] -> [(Int, a)]
number Int
first (forall a. Int -> [a] -> [a]
take (Int
lastforall a. Num a => a -> a -> a
-Int
firstforall a. Num a => a -> a -> a
+Int
1) (forall a. Int -> [a] -> [a]
drop Int
first [(FontName, Int)]
mtxt))
	      firsty :: Int
firsty = Int
baseforall a. Num a => a -> a -> a
+Int
lsforall a. Num a => a -> a -> a
*Int
first
	      ys :: [Int]
ys = [Int
firsty,Int
firstyforall a. Num a => a -> a -> a
+Int
ls..]
	  in forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ XCommand -> FRequest
XCmd forall a b. (a -> b) -> a -> b
$ Rect -> Bool -> XCommand
ClearArea Rect
r Bool
False,
		    forall a b. a -> Message a b
Low forall a b. (a -> b) -> a -> b
$ [(GCId, [DrawCommand])] -> FRequest
wDrawMany
	             [(forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> GCId
dgc [Int]
sel Int
n,[Point -> FontName -> DrawCommand
drimstr (Int -> Int -> Point
Point Int
x1 Int
ly) FontName
s]) | 
		     ((Int
n,FontName
s,Int
x1,Int
x2),Int
ly)<-forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. (a, (b, Int)) -> (a, b, Int, Int)
xi [(Int, (FontName, Int))]
lines) [Int]
ys,Int
xforall a. Ord a => a -> a -> Bool
<Int
x2 Bool -> Bool -> Bool
&& (Int
xforall a. Num a => a -> a -> a
+Int
w)forall a. Ord a => a -> a -> Bool
>=Int
x1]]
		     -- !! The x coordnates should probably be stored
		     -- rather than recomputed every time the text is
		     -- redrawn...

        xi :: (a, (b, Int)) -> (a, b, Int, Int)
xi (a
n,(b
s,Int
w)) = (a
n,b
s,Int
x1,Int
x2) where x1 :: Int
x1=Int -> Int
x0 Int
w; x2 :: Int
x2=Int
x1forall a. Num a => a -> a -> a
+Int
w
        x0 :: Int -> Int
x0 Int
w = Int
marginforall a. Num a => a -> a -> a
+forall a b. (RealFrac a, Integral b) => a -> b
floor (p
alignforall a. Num a => a -> a -> a
*fromInt (winwidth-margin-w))
	       -- !!! Problem: can't be sure that bitgravity moves stuff
	       -- to the same pixel coordinates that are computed here...

    dgc :: t a -> a -> GCId
dgc t a
sel a
n = if a
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
sel -- inefficient !!
                then GCId
gcinv
		else GCId
gc

resizeK :: [KCommand b] -> (Point -> K a b) -> K a b
resizeK [KCommand b]
cmd Point -> K a b
cont = forall {b} {a}. [KCommand b] -> K a b -> K a b
putsK [KCommand b]
cmd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> * -> *) hi ans ho.
FudgetIO f =>
(KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
waitForMsg forall {b}. Message FResponse b -> Maybe Point
ans forall a b. (a -> b) -> a -> b
$ Point -> K a b
cont
  where ans :: Message FResponse b -> Maybe Point
ans (Low (LEvt (LayoutSize Point
newsize))) = forall a. a -> Maybe a
Just Point
newsize
        ans Message FResponse b
_ = forall a. Maybe a
Nothing

doubleClickTime :: Int
doubleClickTime = Int
400 -- The double click timeout should not be hard wired like this...
textbg :: ColorSpec
textbg = forall {a}. (Show a, ColorGen a) => a -> ColorSpec
colorSpec [FontName
bgColor,FontName
"white"]
textfg :: ColorSpec
textfg = forall {a}. (Show a, ColorGen a) => a -> ColorSpec
colorSpec [FontName
fgColor,FontName
"black"]

horizAlignGravity :: Alignment -> Gravity
horizAlignGravity Alignment
align =
    case (Alignment
align::Alignment) of
      Alignment
0 -> Gravity
NorthWestGravity
      Alignment
0.5 -> Gravity
NorthGravity
      Alignment
1 -> Gravity
NorthEastGravity
      Alignment
_ -> Gravity
ForgetGravity

--take' n | n>=0 = take n