{-# 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)
{-
HBC uses "cpp -C -traditional" which causes all the to be left behind
when the macro definitions are processed. That is why the definitions
are inside a comment.
-}
default(Int) -- mostly for Hugs
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
instance HasBorderWidth (TextF) where { setBorderWidth p (Pars ps) = Pars (BorderWidth p:ps); getBorderWidthMaybe (Pars ps) = getparMaybe (\x->case x of BorderWidth p -> Just p; _-> Nothing) ps }
instance HasFgColorSpec (TextF) where { setFgColorSpec p (Pars ps) = Pars (FgColorSpec p:ps); getFgColorSpecMaybe (Pars ps) = getparMaybe (\x->case x of FgColorSpec p -> Just p; _-> Nothing) ps }
instance HasBgColorSpec (TextF) where { setBgColorSpec p (Pars ps) = Pars (BgColorSpec p:ps); getBgColorSpecMaybe (Pars ps) = getparMaybe (\x->case x of BgColorSpec p -> Just p; _-> Nothing) ps }
instance HasFontSpec (TextF) where { setFontSpec p (Pars ps) = Pars (FontSpec p:ps); getFontSpecMaybe (Pars ps) = getparMaybe (\x->case x of FontSpec p -> Just p; _-> Nothing) ps }
instance HasAlign (TextF) where { setAlign p (Pars ps) = Pars (Align p:ps); getAlignMaybe (Pars ps) = getparMaybe (\x->case x of Align p -> Just p; _-> Nothing) ps }
instance HasMargin (TextF) where { setMargin p (Pars ps) = Pars (Margin p:ps); getMarginMaybe (Pars ps) = getparMaybe (\x->case x of Margin p -> Just p; _-> Nothing) ps }
instance HasInitText (TextF) where { setInitText p (Pars ps) = Pars (InitText p:ps); getInitTextMaybe (Pars ps) = getparMaybe (\x->case x of InitText p -> Just p; _-> Nothing) ps }
--instance HasInitSize (TextF) where { setInitSize p (Pars ps) = Pars (InitSize p:ps); getInitSizeMaybe (Pars ps) = getparMaybe (\x->case x of InitSize p -> Just p; _-> Nothing) ps }
instance HasSizing (TextF) where { setSizing p (Pars ps) = Pars (Sizing p:ps); getSizingMaybe (Pars ps) = getparMaybe (\x->case x of Sizing p -> Just p; _-> Nothing) ps }
instance HasStretchable (TextF) where { setStretchable p (Pars ps) = Pars (Stretchable p:ps); getStretchableMaybe (Pars ps) = getparMaybe (\x->case x of Stretchable p -> Just p; _-> Nothing) ps }
textF = textF' standard
textF' pm = noPF $ textF'' pm
textF'' :: Customiser TextF ->
PF TextF TextRequest (InputMsg (Int, String))
textF'' pmod =
let ps :: TextF
ps = pmod (Pars [BorderWidth 0,
FgColorSpec textfg,
BgColorSpec textbg,
Margin 2,
Align aLeft,
InitText [],--InitSize "",
Stretchable (False,False),
Sizing Dynamic,
FontSpec (fontSpec defaultFont)])
bw = getBorderWidth ps
fg = getFgColorSpec ps
bg = getBgColorSpec ps
font = getFontSpec ps
init = getInitText ps
minstr = "" --getInitSize ps
margin = getMargin ps
align = getAlign ps
sizing = getSizing ps
stretch = getStretchable ps
eventmask = [ExposureMask, ButtonPressMask]
startcmds = map XCmd
[ConfigureWindow [CWBorderWidth bw],
ChangeWindowAttributes
[CWEventMask eventmask
,CWBitGravity (horizAlignGravity align)
,CWBackPixmap none -- elim flicker caused by XClearArea
]]
in doubleClickF doubleClickTime $
windowF startcmds $ textK0 bg fg font stretch align sizing margin minstr init
textK0 bg fg font (flexh,flexv) align sizing margin minstr init =
changeGetBackPixel bg $ \ bgcol ->
convColorK fg $ \ fgcol ->
--allocNamedColorPixel defaultColormap fg $ \ fgcol ->
convFontK font $ \ fd ->
fontdata2struct fd $ \ fs ->
wCreateGC rootGC [GCFont (font_id fs),
GCForeground fgcol,
GCBackground bgcol] $ \gc ->
wCreateGC gc [GCForeground bgcol,
GCBackground fgcol] $ \gcinv ->
let minw = next_pos fs minstr
in textK1 bgcol gc gcinv fs (not flexh) (not flexv) align sizing margin minw init
textK1 bgcol gc gcinv fs fh fv align sizing margin minw =
replaceTextK origin origin [] [] 0 listEnd
where
ll size = Low (layoutRequestCmd (plainLayout size fh fv))
ls = linespace fs
base = font_ascent fs + margin
margsize = diag (2*margin)
measure = map (pairwith (next_pos fs))
txtwidth mtxt = maximum (1:minw:map snd mtxt)
-- 0 width not allowed for windows
drimstr = if snd (font_range fs) > '\xff'
then DrawImageString16
else DrawImageString
txtsize mtxt =
let width = txtwidth mtxt
height = max 1 (ls*length mtxt) -- 0 height not allowed for windows
in Point width height
replaceTextK winsize@(Point winwidth winheight) size sel mtxt dfrom dcnt newtxt=
let lines = length mtxt
from = min lines (if dfrom==listEnd then lines else dfrom)
after = lines-from
cnt = min after (if dcnt==listEnd then after else dcnt)
newcnt = length newtxt
diff = newcnt-cnt
scrollsize= after-cnt
newlines = lines+diff
sel' = mapMaybe reloc sel
reloc n = if n<from then Just n
else if n<from+cnt then Nothing
else Just (n+diff)
mtxt' = take from mtxt ++ measure newtxt ++
(if scrollsize>0 then drop (from+cnt) mtxt else [])
newwidth = txtwidth mtxt'
newsize = Point newwidth (ls*newlines)
llcmd = let realwinsize@(Point w h) = winsize+diag margin
winsize'@(Point w' h') = newsize +margsize
change =
winsize==origin ||
newSize sizing realwinsize winsize'/=realwinsize
in if change
then [ll (newsize + margsize)]
else []
--width = xcoord size
drawwidth = max newwidth (winwidth-margin)
-- !! always scrolls/clears the full width of the window
scrollrect= rR margin (margin+ls*(from+cnt))
drawwidth (ls*scrollsize)
scrolldest= Point margin (margin+ls*(from+newcnt))
scrollcmd = if scrollsize>0 && diff/=0
then [Low (wDraw gc $ CopyArea MyWindow scrollrect scrolldest)]
else []
drawrect = rR margin (margin+ls*from) (drawwidth+margin) (ls*newcnt)
-- add margin to width to erase text in the margin
-- when the text is wider than the window.
belowrect = rR margin (margin+ls*newlines) drawwidth (-ls*diff)
clearcmd = (if newcnt>0
then let vrect = growrect drawrect (pP 5 5) -- !! tmp fix
in clearArea drawrect True++
[Low (LCmd (layoutMakeVisible vrect))]
else [])++
(if diff<0
then [Low $ XCmd $ ClearArea belowrect 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 r e = map (Low . XCmd)
[ChangeWindowAttributes [CWBackPixmap none],
ClearArea r e,
ChangeWindowAttributes [CWBackPixel bgcol]]
-- Some backround may be lost if the windows becomes
-- obscured while the BackPixmap is none !!!
in if diff>0
then resizeK llcmd $ \ newwinsize ->
putsK (scrollcmd++clearcmd) $
textK (newwinsize - diag margin) newsize sel' mtxt'
else putsK (scrollcmd++clearcmd++llcmd) $
textK winsize newsize sel' mtxt'
textK :: Size -> Size -> [Int] -> [(String,Int)] ->
PK TextF TextRequest (InputMsg (Int,String))
textK winsize@(Point winwidth _) size sel mtxt =
-- winsize is the size of the window excluding the right & bottom margins
getK $ message lowK (either paramChangeK textRequestK)
where
same = textK winsize size sel mtxt
textRequestK msg =
case msg of
ReplaceItems dfrom dcnt newtxt ->
replaceTextK winsize size sel mtxt dfrom dcnt newtxt
HighlightItems sel' ->
changeHighlightK sel' $
textK winsize size sel' mtxt
PickItem n -> output inputMsg n
_ -> same
lowK event =
case event of
XEvt (ButtonEvent {button=Button 1,pos=Point _ y, type'=press}) ->
let l=y `quot` ls
pressmsg = case press of
MultiClick 2 -> inputMsg
_ -> InputChange
in output pressmsg l
XEvt (Expose {rect=r}) ->
redrawTextK r $
same
XEvt (GraphicsExpose {rect=r}) ->
redrawTextK r $
same
LEvt (LayoutSize newwinsize) ->
textK (newwinsize - diag margin) size sel mtxt
_ -> same
paramChangeK _ = same -- !!! Dynamic customisation not implemented yet
output pressmsg l = (if l>=0 && l<length mtxt
then putK (High (pressmsg (l,fst(mtxt!!l))))
else id) $ same
changeHighlightK sel' =
putsK (mkvis++[Low $ wDrawMany (map draw changes)])
where
changed n = (n `elem` sel) /= (n `elem` sel')
nmtxt = number 0 mtxt
changes = [l | l@(n,_)<-nmtxt, changed n]
selected = [l | l@(n,_)<-nmtxt, n `elem` sel']
draw (n,(s,w)) = (dgc sel' n,[drimstr (Point (x0 w) (base+n*ls)) s])
mkvis =
case (selected,last selected) of -- needs lazy evalution!
([],_) -> []
((n1,(_,w1)):_,(n2,(_,w2))) ->
[Low (LCmd (layoutMakeVisible vrect))]
where vrect = rR x1 y1 (x2-x1+5) (y2-y1+5)
x1 = min (x0 w1) (x0 w2) -- !!! Should use min/max
x2 = max (x0 w1) (x0 w2) -- !!! of all changes.
y1 = n1*ls
y2 = (n2+1)*ls
redrawTextK r@(Rect (Point x y) (Point w h)) =
let first = (max 0 (y-margin)) `quot` ls
last = (y+h-1) `quot` ls
lines = number first (take (last-first+1) (drop first mtxt))
firsty = base+ls*first
ys = [firsty,firsty+ls..]
in putsK [Low $ XCmd $ ClearArea r False,
Low $ wDrawMany
[(dgc sel n,[drimstr (Point x1 ly) s]) |
((n,s,x1,x2),ly)<-zip (map xi lines) ys,x<x2 && (x+w)>=x1]]
-- !! The x coordnates should probably be stored
-- rather than recomputed every time the text is
-- redrawn...
xi (n,(s,w)) = (n,s,x1,x2) where x1=x0 w; x2=x1+w
x0 w = margin+floor (align*fromIntegral (winwidth-margin-w))
-- !!! Problem: can't be sure that bitgravity moves stuff
-- to the same pixel coordinates that are computed here...
dgc sel n = if n `elem` sel -- inefficient !!
then gcinv
else gc
resizeK cmd cont = putsK cmd $ waitForMsg ans $ cont
where ans (Low (LEvt (LayoutSize newsize))) = Just newsize
ans _ = Nothing
doubleClickTime = 400 -- The double click timeout should not be hard wired like this...
textbg = colorSpec [bgColor,"white"]
textfg = colorSpec [fgColor,"black"]
horizAlignGravity align =
case (align::Alignment) of
0 -> NorthWestGravity
0.5 -> NorthGravity
1 -> NorthEastGravity
_ -> ForgetGravity
--take' n | n>=0 = take n