Commit d120bc74 authored by Diederik van Arkel's avatar Diederik van Arkel

Commit windows mods

parent c85ad9d9
......@@ -4,6 +4,7 @@ definition module EdLineText
from StrictList import :: StrictList
from EdPosition import :: LineNr
from syncol import :: Info
:: Text
:: TextFragment
......@@ -25,7 +26,7 @@ lastLineNr :: !Text -> LineNr
validateLineNr :: !LineNr Text -> LineNr
getLine :: !LineNr !u:Text -> (!String, !u:Text)
getLineC :: !LineNr !u:Text -> ((!Int,!String), !u:Text)
getLineC :: !LineNr !u:Text -> ((!Info,!String), !u:Text)
getLines :: LineNr LineNr Text -> (StrictList String, Text)
//getLinesC :: LineNr LineNr Text -> (StrictList (Int,String), Text)
......
......@@ -21,8 +21,8 @@ where
export TextAnnot Void, SyncInf, ConsInf
*/
:: LineAnnot :== Int
dummyLineAnnot :== 0
:: LineAnnot :== Info
dummyLineAnnot :== (0,False)
annotLine :== slMap (\s->(dummyLineAnnot,s))
annotWhole :== firstParse
annotPart :== quickParse
......@@ -64,7 +64,7 @@ textToStrings :: !Text -> StrictList String
textToStrings { blocks }
= blocksToStrings blocks
textToStringsC :: !Text -> StrictList (Int,String)
textToStringsC :: !Text -> StrictList (Info,String)
textToStringsC { blocks }
= blocksToStringsC blocks
......@@ -133,15 +133,15 @@ where
StringToText s
:== stringsToText (stringToStrings s)
blockToStrings :: !(StrictList (Int,String)) -> StrictList String
blockToStrings :: !(StrictList (Info,String)) -> StrictList String
blockToStrings block = slMap snd block
blocksToStrings :: ![StrictList (Int,String)] -> StrictList String
blocksToStrings :: ![StrictList (Info,String)] -> StrictList String
blocksToStrings [] = SNil
blocksToStrings [block:blocks]
= slAppend (blockToStrings block) (blocksToStrings blocks)
blocksToStringsC :: ![StrictList (Int,String)] -> StrictList (Int,String)
blocksToStringsC :: ![StrictList (Info,String)] -> StrictList (Info,String)
blocksToStringsC [] = SNil
blocksToStringsC [block:blocks]
= slAppend block (blocksToStringsC blocks)
......@@ -181,7 +181,7 @@ where
nrSkip = lineNr / BlockSize
theBlock = blocks!!nrSkip
getLineC :: !LineNr !u:Text -> ((!Int,!String), !u:Text)
getLineC :: !LineNr !u:Text -> ((!Info,!String), !u:Text)
getLineC linenr text=:{nrLines, blocks}
# line = slIndex lineNr` theBlock
= ( line, text)
......@@ -197,7 +197,7 @@ where
// denotes by the line numbers. It also returns the number of
// the first block
getBlocks :: LineNr LineNr Text -> (Int, [StrictList (Int,String)])
getBlocks :: LineNr LineNr Text -> (Int, [StrictList (Info,String)])
getBlocks first last { blocks }
= ( nrSkip
, blocks%(nrSkip,nrTake)
......@@ -216,7 +216,7 @@ where
(firstBlockNr, blocks) = getBlocks first last text
first` = first - firstBlockNr * BlockSize
getLinesC :: LineNr LineNr Text -> (StrictList (Int,String), Text)
getLinesC :: LineNr LineNr Text -> (StrictList (Info,String), Text)
getLinesC first last text
# lines = textToStringsC text
# lines = slTake (last - first + 1) (slDrop first lines)
......
......@@ -53,6 +53,7 @@ from EdSelection import :: Selection, :: Position, :: ColumnNr, :: LineNr
, stringColour :: !Colour
, charColour :: !Colour
, keywordColour :: !Colour
, typedefColour :: !Colour
}
DefaultSyntaxColours :: SyntaxColours
......
......@@ -87,6 +87,7 @@ import EdAction
, stringColour :: !Colour
, charColour :: !Colour
, keywordColour :: !Colour
, typedefColour :: !Colour
}
instance toString ActionInfo
......@@ -410,6 +411,7 @@ DefaultSyntaxColours =
, stringColour = Green
, charColour = Magenta
, keywordColour = Grey
, typedefColour = Black
}
//--
......
......@@ -91,7 +91,7 @@ mouse (MouseDrag point modifiers) // mouse drag
getText >>>= \text ->
vChangeSelectionTo (selectLines firstLine newPosition.row text)
) >>>
vScrollToCursor
vDragCursor point
mouse (MouseUp point modifiers) // mouse up handling
= getSelection >>>= \selection ->
......
definition module EdPosition
from StdClass import class <, class ==
from StdClass import class <, class ==, class toString
:: Position
= { col :: ColumnNr
......@@ -12,3 +12,4 @@ from StdClass import class <, class ==
instance < Position
instance == Position
instance toString Position
implementation module EdPosition
import StdClass, StdBool, StdInt
import StdClass, StdBool, StdInt, StdString
:: Position
= { col :: ColumnNr
......@@ -20,3 +20,5 @@ instance < Position where
(<) { col=col1, row=row1 } { col=col2, row=row2 }
= row1 < row2 || (row1 == row2 && col1 < col2)
instance toString Position where
toString {col,row} = "(" +++ toString row +++ "," +++ toString col +++ ")"
......@@ -2,9 +2,10 @@ definition module EdTab
// functions that deal with those annoying tab characters
from StdIOCommon import :: Point2
from StdPicture import :: Picture
from EdMonad import :: FontInfo
from StdIOCommon import :: Point2
from StdPicture import :: Picture
from EdMonad import :: FontInfo
from syncol import :: Info
splitAtTabs :: !String -> .[String]
// splitAtTabs: splits a string into several strings that were
......@@ -17,7 +18,6 @@ tabTake :: !Int [String] -> [String]
// ["abc",""]
tabDrawString :: !Point2 !String !FontInfo !*Picture -> *Picture
tabDrawStringC :: !Point2 !(!Int,!String) !FontInfo !*Picture -> *Picture
tabDrawStringC :: !Point2 !(!Info,!String) !FontInfo !*Picture -> *Picture
// tabDrawString: draws a string containing tabs properly.
// tabDrawStringC: draws a string containing tabs properly with syntax colours.
......@@ -9,7 +9,7 @@ implementation module EdTab
import StdArray, StdBool, StdClass, StdEnum, StdList
import StdIOCommon, StdPicture, StdPSt
import EdMonad
import EdMonad, syncol
//--
......@@ -86,53 +86,56 @@ where
| L // comment till end of line...
| S // in string constant...
| C // in char constant...
| T Int // in typedef
import ospicture // for optimized drawfuns...
optDrawS :== pictdrawstring // use non-optimised versions
optDrawC :== pictdrawchar // "
tabDrawStringC :: !Point2 !(!Int,!String) !FontInfo !*Picture -> *Picture
tabDrawStringC point (clevel,string)
{tabSize,charWidth,thefont, showTabs, syntaxColours={textColour, backgroundColour,tabColour, commentColour, stringColour, charColour, keywordColour}}
tabDrawStringC :: !Point2 !(!Info,!String) !FontInfo !*Picture -> *Picture
tabDrawStringC point ((clevel,typedef),string)
{tabSize,charWidth,thefont, showTabs, syntaxColours={textColour, backgroundColour,tabColour, commentColour, stringColour, charColour, keywordColour, typedefColour}}
picture
#! strings = splitAtTabs string
= tabDrawString` (N clevel) point strings picture
| typedef
= tabDrawString` True (T clevel) point strings picture
= tabDrawString` True (N clevel) point strings picture
where
tabDrawString` :: !CommentLevel !Point2 !.[String] !*Picture -> *Picture
tabDrawString` :: !Bool !CommentLevel !Point2 !.[String] !*Picture -> *Picture
// hmm, need to get if column 0 into local funs...
tabDrawString` _ _ [] picture
tabDrawString` _ _ _ [] picture
// #! (_,picture) = optGetPenPos picture
= picture
tabDrawString` clevel point [string : []] picture
tabDrawString` ini clevel point [string : []] picture
// #! (_,picture) = optGetPenPos picture
#! picture = setPenPos point picture
#! (_,picture) = drawC clevel string picture
#! (_,picture) = drawC ini clevel string picture
// #! (_,picture) = optGetPenPos picture
= picture
tabDrawString` clevel point [string : strings] picture
tabDrawString` ini clevel point [string : strings] picture
// #! (_,picture) = optGetPenPos picture
#! picture = setPenPos point picture
#! (clevel,picture) = drawC clevel string picture
#! (clevel,picture) = drawC ini clevel string picture
// #! (newPoint,picture) = optGetPenPos picture
#! (newPoint,picture) = getPenPos picture
#! newX = alignAtTab` newPoint.x tabSize charWidth
| not showTabs
= tabDrawString` clevel {point & x = newX} strings picture
= tabDrawString` False clevel {point & x = newX} strings picture
#! picture = setPenColour tabColour picture
#! picture = optDrawC '~' picture
#! picture = setPenColour textColour picture
= tabDrawString` clevel {point & x = newX} strings picture
= tabDrawString` False clevel {point & x = newX} strings picture
drawC :: !.CommentLevel !.String !*Picture -> (!.CommentLevel,!*Picture)
drawC c s pic
drawC :: !Bool !CommentLevel !.String !*Picture -> (!CommentLevel,!*Picture)
drawC ini c s pic
= drawC c pic
where
drawC :: !.CommentLevel !*Picture -> (!.CommentLevel,!*Picture)
drawC :: !CommentLevel !*Picture -> (!CommentLevel,!*Picture)
drawC S pic // string literal
# pic = setPenColour stringColour pic
= dS 0 pic
......@@ -145,7 +148,10 @@ where
= (L,pic)
drawC (N cl) pic // normal
# pic = (if (cl==0) (setPenColour textColour) (setPenColour commentColour)) pic
= dL cl 0 pic
= dL ini (N cl) 0 pic
drawC (T cl) pic
# pic = (if (cl==0) (setPenColour typedefColour) (setPenColour commentColour)) pic
= dL ini (T cl) 0 pic
l = size s
funnyChar i = isStringMember s.[i] (dec funnySize) funnyChars
......@@ -159,84 +165,151 @@ where
funnyChars =: "~@#$%^?!+-*<>\\/|&=:."
funnySize = 20
dL :: !.Int !.Int !*Picture -> (!.CommentLevel,!*Picture)
dL cl i pic
dL :: !Bool !CommentLevel !.Int !*Picture -> (!CommentLevel,!*Picture)
dL ini cl i pic
| i >= l
= (N cl,pic)
= (cl,pic)
| ini && s.[i] == ':' && not (in_comment cl)
# i` = inc i
| i` >= l
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC ':' pic
= (N 0,pic)
| s.[i`] == ':'
# i`` = inc i`
| i`` < l && funnyChar i``
# j = scanfunny i
# r = s%(i,dec j)
# pic = optDrawS r pic
= dL False (N 0) j pic
# pic = setPenColour typedefColour pic
# pic = optDrawS "::" pic
= dL False (T 0) i`` pic
| s.[i`] == '='
# i`` = inc i`
| i`` < l && funnyChar i``
# j = scanfunny i
# r = s%(i,dec j)
# (cl,pic) = case r of
":==" -> (cl,pic)
_ -> normalise ini i cl pic
# pic = optDrawS r pic
= dL False cl j pic
# (cl,pic) = normalise ini i cl pic
# pic = optDrawS ":=" pic
= dL False (N 0) i`` pic
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC ':' pic
= dL False (N 0) i` pic
| s.[i] == '*'
# i = inc i
| i >= l
# i` = inc i
| i` >= l
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC '*' pic
= (N cl,pic)
| s.[i] == '/'
# i = inc i
| cl <> 0
= (cl,pic)
| s.[i`] == '/'
# i`` = inc i`
| in_comment cl //cl <> 0
# pic = setPenColour commentColour pic // idiot proof for trickery at start of text...
# pic = optDrawS "*/" pic
# cl = dec cl
| cl == 0
# pic = setPenColour textColour pic
= dL cl i pic
= dL cl i pic
# cl = dec_comment cl
| not (in_comment cl) //cl == 0
# pic = setPenColour (non_comment_colour cl)/*textColour*/ pic
= dL False cl i`` pic
= dL False cl i`` pic
| i < l && funnyChar i
| i`` < l && funnyChar i``
// eat till end of funnyid substring...
# j = scanfunny i
# r = s%(i,dec j)
# j = scanfunny i``
# r = s%(i``,dec j)
# (cl,pic) = normalise ini i cl pic
# pic = optDrawS "*/" pic
# pic = optDrawS r pic
= dL cl j pic
= dL False cl j pic
# pic = setPenColour commentColour pic // idiot proof for trickery at start of text...
# pic = optDrawS "*/" pic
# cl = dec cl
| cl == 0
# pic = setPenColour textColour pic
= dL cl i pic
= dL cl i pic
# cl = dec_comment cl
| not (in_comment cl) //cl == 0
# pic = setPenColour (non_comment_colour cl)/*textColour*/ pic
= dL False cl i`` pic
= dL False cl i`` pic
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC '*' pic
= dL cl i pic
= dL False cl i` pic
| s.[i] == '/'
# i = inc i
| i >= l
# i` = inc i
| i` >= l
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC '/' pic
= (N cl,pic)
| s.[i] == '/'
= (cl,pic)
| s.[i`] == '/'
# pic = setPenColour commentColour pic
# pic = optDrawS "//" pic
# r = s%(inc i,l)
# r = s%(inc i`,l)
# pic = optDrawS r pic
= (L,pic)
| s.[i] == '*'
| s.[i`] == '*'
# pic = setPenColour commentColour pic
# pic = optDrawS "/*" pic
= dL (inc cl) (inc i) pic
# cl = inc_comment cl
= dL False cl (inc i`) pic
# (cl,pic) = normalise ini i cl pic
# pic = optDrawC '/' pic
= dL cl i pic
| (s.[i] == '"') && (cl == 0)
= dL False cl i` pic
| (s.[i] == '"') && (not (in_comment cl)) //(cl == 0)
# pic = setPenColour stringColour pic
# pic = optDrawC '"' pic
= dS (inc i) pic
| (s.[i] == '\'') && (cl == 0)
| (s.[i] == '\'') && (not (in_comment cl)) //(cl == 0)
# pic = setPenColour charColour pic
# pic = optDrawC '\'' pic
= dC (inc i) pic
| (cl == 0) && (funnyChar i)
| /*(cl == 0)*/ (not (in_comment cl)) && (funnyChar i)
# j = scanfunny i
# r = s%(i,dec j)
# (cl,pic) = case r of
"|" -> (cl,pic)
"=" -> (cl,pic)
_ -> normalise ini i cl pic
# pic = optDrawS r pic
= dL cl j pic
= dL False cl j pic
# (cl,pic) = case WhiteSpace s.[i] of
True -> (cl,pic)
_ -> normalise ini i cl pic
# (key,j) = scankeyword s i
| key && cl == 0
| key && (not (in_comment cl)) //cl == 0
# r = s%(i,dec j)
# (c,pic) = getPenColour pic
# pic = setPenColour keywordColour pic
# pic = optDrawS r pic
# pic = setPenColour c pic
= dL cl j pic
= dL False cl j pic
# r = s%(i,dec j)
# pic = optDrawS r pic
= dL cl j pic
= dL False cl j pic
where
normalise True 0 (T 0) pic
# pic = setPenColour textColour pic
= (N 0,pic)
normalise _ _ cl pic
= (cl,pic)
in_typedef cl = case cl of
T l -> l == 0
_ -> False
in_comment cl = case cl of
N l -> l <> 0
T l -> l <> 0
_ -> False
dec_comment cl = case cl of
N l -> N (dec l)
T l -> T (dec l)
inc_comment cl = case cl of
N l -> N (inc l)
T l -> T (inc l)
non_comment_colour cl = case cl of
N _ -> textColour
T _ -> typedefColour
scankeyword :: !.String !Int -> (!Bool,!Int)
scankeyword s i
# c = s.[i]
......@@ -253,6 +326,7 @@ where
| c == 'd' // definition
| (j == i+10) && (s%(i,i+9)=="definition") = (True,j)
| (j == i+7) && (s%(i,i+6)=="default") = (True,j) // only in typedef!
| (j == i+7) && (s%(i,i+6)=="dynamic") = (True,j)
= (False,j)
| c == 'i' // implementation, import, if, in, infix, infixl, infixr, instance
| (j == i+14) && (s%(i,i+13)=="implementation") = (True,j)
......@@ -315,14 +389,14 @@ where
| funnyChar i = scanfunny (inc i)
= i
dS :: !Int !*Picture -> (!.CommentLevel,!*Picture)
dS :: !Int !*Picture -> (!CommentLevel,!*Picture)
dS i pic
| i >= l
= (S,pic)
| s.[i] == '"'
# pic = optDrawC '"' pic
# pic = setPenColour textColour pic
= dL 0 (inc i) pic
= dL False (N 0) (inc i) pic
| s.[i] == '\\'
# pic = optDrawC '\\' pic
# i = inc i
......@@ -332,14 +406,14 @@ where
= dS (inc i) pic
# pic = optDrawC s.[i] pic
= dS (inc i) pic
dC :: !Int !*Picture -> (!.CommentLevel,!*Picture)
dC :: !Int !*Picture -> (!CommentLevel,!*Picture)
dC i pic
| i >= l
= (C,pic)
| s.[i] == '\''
# pic = optDrawC '\'' pic
# pic = setPenColour textColour pic
= dL 0 (inc i) pic
= dL False (N 0) (inc i) pic
| s.[i] == '\\'
# pic = optDrawC '\\' pic
# i = inc i
......@@ -349,3 +423,6 @@ where
= dC (inc i) pic
# pic = optDrawC s.[i] pic
= dC (inc i) pic
WhiteSpace c
:== c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f';
......@@ -23,6 +23,10 @@ vScrollToCursor :: EditMonad (PSt .l) nothing
// vScrollToCursor: scrolls the view frame up to the point that the cursor
// becomes visible.
vDragCursor :: !Point2 -> EditMonad (PSt .l) nothing
// vDragToCursor: scrolls the view frame up to the point that the cursor
// becomes visible with space to spare.
vMoveCursor :: !Movement -> EditMonad (PSt .l) nothing
vDoCursorSafe :: (EditMonad (PSt .l) a) -> EditMonad (PSt .l) a
......
......@@ -10,18 +10,22 @@ import ioutil, StrictList
//--
vCenterCursor :: EditMonad (PSt .l) nothing
vCenterCursor = vMakeCursorVisible True
vCenterCursor = vMakeCursorVisible True Nothing
vScrollToCursor :: EditMonad (PSt .l) nothing
vScrollToCursor = vMakeCursorVisible False
vScrollToCursor = vMakeCursorVisible False Nothing
vMakeCursorVisible :: !Bool -> EditMonad (PSt .l) nothing
vMakeCursorVisible center =
vDragCursor :: !Point2 -> EditMonad (PSt .l) nothing
vDragCursor point = vMakeCursorVisible False (Just point)
vMakeCursorVisible :: !Bool !(Maybe Point2) -> EditMonad (PSt .l) nothing
vMakeCursorVisible center drag =
getWindowId >>>= \windowId ->
accEnv (accPIO (getWindowViewFrame windowId)) >>>= \viewFrame ->
getSelection >>>= \{end} ->
// accEnv (accPIO (getWindowViewDomain windowId)) >>>= \viewDomain ->
getSelection >>>= \{start,end} ->
getText >>>= \text ->
getFontInfo >>>= \fontInfo=:{FontInfo | lineHeight} ->
getFontInfo >>>= \fontInfo=:{FontInfo | lineHeight,charWidth} ->
let // give names to the components of the view frame
cursorPoint = positionToPoint end text fontInfo
left = viewFrame.corner1.x
......@@ -31,14 +35,80 @@ vMakeCursorVisible center =
// determine whether the cursor is on the
// correct (visible) side of the borders
leftOk = cursorPoint.x >= left
rightOk = cursorPoint.x <= right
leftOk = cursorPoint.x - charWidth >= left
// leftOk = case end.col of
// 0 -> (fromJust viewDomain).corner1.x = left
// _ -> cursorPoint.x - charWidth >= left
rightOk = cursorPoint.x + charWidth <= right
topOk = cursorPoint.y >= top
bottomOk = cursorPoint.y + lineHeight <= bottom
cursorOk = leftOk && rightOk && topOk && bottomOk
singleline= end.row - start.row == 0
(dontMove,nrHPixels)
= case drag of
Just point #
hslop` = charWidth
vslop` = lineHeight
// leftOk` = point.x - hslop` >= left
// rightOk` = point.x + hslop` <= right
leftOk` = point.x >= left
rightOk` = point.x <= right
topOk` = point.y >= top
bottomOk` = point.y <= bottom
mouseOk = leftOk` && rightOk` && topOk` && bottomOk`
hslop`` = charWidth * 8
vslop`` = lineHeight
leftOk`` = cursorPoint.x - hslop`` >= left
rightOk`` = cursorPoint.x + hslop`` <= right
topOk`` = cursorPoint.y >= top
bottomOk`` = cursorPoint.y + vslop`` <= bottom
cursorOk`` = leftOk`` && rightOk`` && topOk`` && bottomOk``
/*
nrHPixels = if (leftOk`` && rightOk``)
0
(if rightOk``
( point.x - hslop` - left )
( point.x + hslop` - right )
)
*/
nrHPixels`` = if (leftOk`` && rightOk``)
0
(if rightOk``
(~charWidth)//( point.x - hslop` - left )
charWidth//( point.x + hslop` - right )
)
nrHPixels = if (leftOk && rightOk)
0
(if rightOk
( cursorPoint.x - charWidth - left )
( cursorPoint.x + charWidth - right )
)
/* nrHPixels = if (leftOk`` && rightOk``)
0
(if rightOk``
( cursorPoint.x - hslop`` - left )
( cursorPoint.x + hslop`` - right )
)
*/
// -> (if singleline (mouseOk || cursorOk``) (cursorOk``), nrHPixels)
-> if singleline
(mouseOk || cursorOk``,nrHPixels``)
(cursorOk``,nrHPixels)
Nothing #
nrHPixels = if (leftOk && rightOk)
0
(if rightOk
( cursorPoint.x - charWidth - left )
( cursorPoint.x + charWidth - right )
)
-> (cursorOk, nrHPixels)
in
// if cursor is visible, nothing has to be done
IF (leftOk && rightOk && topOk && bottomOk)
IF (dontMove)
THEN
( skip )
ELSE
......@@ -47,7 +117,7 @@ vMakeCursorVisible center =
halfWidth = ( right - left ) / 2
newTop = if (topOk && bottomOk) top (cursorPoint.y - halfHeight)
newLeft = if (leftOk && rightOk) left (cursorPoint.x - halfWidth)
nrPixels = if (topOk && bottomOk)
nrVPixels = if (topOk && bottomOk)
0 // if visible do nothing
(if bottomOk
( cursorPoint.y - top ) // if move up move to top...
......@@ -55,7 +125,7 @@ vMakeCursorVisible center =
)
vector = if center
{ vx = newLeft - left, vy = newTop - top }
{ vx = newLeft - left, vy = nrPixels }
{ vx = nrHPixels, vy = nrVPixels }
in
appEnv (appPIO (moveWindowViewFrame windowId vector))
)
......@@ -146,11 +216,13 @@ vUpdateCursor visible end height fontInfo text viewFrame rectangles =
{x,y} = point
in
IF (any (isCursorInRectangle point height) rectangles)
THEN (seq
// THEN (seq
THEN (appXorPicture (seq
[ setPenColour Black
, drawLine { x=x, y=y }
{ x=x, y=y+height - 1 }
])
// ])
]))
ELSE