We are planning to upgrade GitLab to the latest version this Friday morning. Expect some downtime!

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.
This diff is collapsed.
......@@ -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
id
)
......@@ -165,13 +237,26 @@ vDrawCursor show end cursorHeight text fontInfo =
in
// ( appXorPicture (seq
// [ setPenColour Black
/*
( (seq
[ setPenColour (if show Black fontInfo.syntaxColours.backgroundColour)
, drawLine { x=x, y=y }
{ x=x, y=y+cursorHeight - 1 }
])
)
*/
( if show
(appXorPicture (seq
[ setPenColour Black
, drawLine { x=x, y=y }
{ x=x, y=y+cursorHeight - 1 }
]))
(seq
[ setPenColour (fontInfo.syntaxColours.backgroundColour)
, drawLine { x=x, y=y }
{ x=x, y=y+cursorHeight - 1 }
])
)
//--- Visual Selection Stuff
vUpdateSelection :: !Selection FontInfo Text ViewFrame [Rectangle] -> (*Picture -> *Picture)
......
......@@ -5,5 +5,7 @@ definition module syncol
import StdString
import StrictList
firstParse :: !(StrictList String) -> StrictList (Int,String)
quickParse :: !Int !Int !(StrictList (Int,String)) -> (Int,StrictList (Int,String))
:: Info :== (!Int,!Bool)
firstParse :: !(StrictList String) -> StrictList (Info,String)
quickParse :: !Int !Int !(StrictList (Info,String)) -> (Int,StrictList (Info,String))
......@@ -9,13 +9,12 @@ import StrictList
parseLine: initial comment nesting level & textline -> new comment nesting level
*/
parseLine :: !.Int !.String -> Int
parseLine :: !.Info !.String -> Info
parseLine comment_level line
= pL comment_level 0
where
funnyChar c = isStringMember c (dec funnySize) funnyChars
//isStringMember:: a !.[a] -> .Bool | Eq a
isStringMember :: !Char !Int !String -> Bool
isStringMember x i s
| i < 0 = False
......@@ -28,64 +27,89 @@ where
line_size = size line
pL :: !Int !Int -> Int
pL l i // parse normal text
| i >= line_size = l
pL :: !Info !Int -> Info
pL (level,typedef) i // parse normal text
| i >= line_size = (level,typedef)
#! char = line.[i]
| char == '*'
# i = inc i
| i >= line_size = l
| i >= line_size = (level,typedef)
| line.[i] == '/'
#! i = inc i
| l <> 0 = pL (dec l) i // try to fix problem below
| level <> 0 = pL (dec level,typedef) i // try to fix problem below
| i < line_size && funnyChar line.[i]
= scanFunny l i // hmmm excludes */*/ and *//*...*/
= pL (dec l) i
= pL l i
= scanFunny (level,typedef) i // hmmm excludes */*/ and *//*...*/
= pL (dec level,typedef) i
= pL (level,typedef) i
| char == '/'
#! i = inc i
| i >= line_size = l
| i >= line_size = (level,typedef)
#! char = line.[i]
| char == '/' = l // shouldn't we exclude funnyId's ??
| char == '*' = pL (inc l) (inc i)
= pL l i
| (char == '"') && (l == 0)
= pS (inc i)
| (char == '\'') && (l == 0)
= pC (inc i)
| (l == 0) && (funnyChar char)
= scanFunny l i
= pL l (inc i)
| char == '/' = (level,typedef) // shouldn't we exclude funnyId's ??
| char == '*' = pL (inc level,typedef) (inc i)
= pL (level,typedef) i
| (char == '"') && (level == 0)
= pS (level,typedef) (inc i)
| (char == '\'') && (level == 0)
= pC (level,typedef) (inc i)
| (level == 0) && (funnyChar char)
= scanFunny (level,typedef) i
| i == 0 && not (WhiteSpace char)
= pL (level,False) (inc i)
= pL (level,typedef) (inc i)
scanFunny l i
| i >= line_size = pL l line_size
scanFunny (level=:0,typedef) 0
| (line_size == 2 && line == "::")
|| (line_size >= 3 && line%(0,1) == "::" && not (funnyChar line.[2]))
= pL (level,True) 2
# c = line.[0]
| typedef
| (line_size == 1 && (line == "|" || line == "="))
|| (line_size >= 2 && (line%(0,0) == "|" || line%(0,0) == "=") && not (funnyChar line.[1]))
|| (line_size == 3 && line == ":==")
|| (line_size >= 4 && line%(0,2) == ":==" && not (funnyChar line.[3]))
= pL (level,typedef) 1
| funnyChar c
= scanFunny (level,False) 1
= pL (level,False) 0
| funnyChar c
= scanFunny (level,typedef) 1
= pL (level,typedef) 0
where
no_c` = line_size < 2
c` = line.[1]
scanFunny (level,typedef) i
| i >= line_size = pL (level,typedef) line_size
#! c = line.[i]
| funnyChar c = scanFunny l (inc i)
= pL l i
| funnyChar c = scanFunny (level,typedef) (inc i)
= pL (level,typedef) i
pS i // parse string constant
| i >= line_size = 0 // unterminated string constant...
pS cl i // parse string constant
| i >= line_size = cl // unterminated string constant...
# char = line.[i]
| char == '"' = pL 0 (inc i)
| char == '"' = pL cl (inc i)
| char == '\\'
= pS (i + 2)
= pS (inc i)
= pS cl (i + 2)
= pS cl (inc i)
pC i // parse character constant
| i >= line_size = 0 // unterminated char constant...
pC cl i // parse character constant
| i >= line_size = cl // unterminated char constant...
# char = line.[i]
| char == '\'' = pL 0 (inc i)
| char == '\\' = pC (i + 2)
= pC (inc i)
| char == '\'' = pL cl (inc i)
| char == '\\' = pC cl (i + 2)
= pC cl (inc i)
// pT i // parse type
WhiteSpace c
:== c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f';
/*
firstParse: textlines -> zip initial comment nesting level & textlines
*/
firstParse :: !(StrictList String) -> StrictList (Int,String)
firstParse :: !(StrictList String) -> StrictList (Info,String)
firstParse lines
= slFromList (fP 0 lines)
= slFromList (fP (0,False) lines)
where
fP i SNil
= []
......@@ -93,31 +117,19 @@ where
#! j = parseLine i h
= [ (i,h) : (fP j t) ]
/*
firstParse lines
= fP 0 lines
where
fP i SNil
= (i,SNil)
fP i (SCons h t)
#! j = parseLine i h
# (k,r) = fP j t
= (k,SCons (i,h) r)
*/
/*
quickParse: (first modified line) (last modified line) textlines
-> last changed line with different comment nesting & textlines
*/
quickParse :: !Int !Int !(StrictList (Int,String)) -> (Int,StrictList (Int,String))
quickParse :: !Int !Int !(StrictList (Info,String)) -> (Int,StrictList (Info,String))
quickParse fln lln text = qP 0 text id
where
// parse before modified
qP :: !Int !.(StrictList (Int,String)) ((StrictList (Int,String)) -> (StrictList (Int,String))) -> (Int, (StrictList (Int,String)))
qP :: !Int !.(StrictList (Info,String)) ((StrictList (Info,String)) -> (StrictList (Info,String))) -> (Int, (StrictList (Info,String)))
qP cln SNil c = (cln,c SNil)
qP cln (SCons h=:(i,l) t) c
| cln < fln = qP (inc cln) t (SC c h)
| cln > lln = qR 0 cln (SCons h t) c
| cln > lln = qR (0,False) cln (SCons h t) c
#! k = parseLine i l
| cln < lln
= qS k (inc cln) t (SC c h)
......@@ -132,20 +144,11 @@ where
= qR k (inc cln) t (SC c (i,l))
// parse after modified
qR k cln SNil c = (cln, c SNil)
qR k cln r=:(SCons (i,l) t) c
| k == i = (dec cln,c r)
# d = k - i
= (cln+slLength t,c (slMap (\(i,l) -> (i+d,l)) r))
qR _ cln SNil c = (cln, c SNil)
qR (level,typedef) cln r=:(SCons ((level`,typedef`),l) t) c
| level == level` && typedef == typedef`
= (dec cln,c r)
# k = parseLine (level,typedef) l
= qR k (inc cln) t (SC c ((level,typedef),l))
SC c h = \t -> c (SCons h t)
//--
/*
Extension to datatype definitions simple...
Need to replace Int by alg datatype
int now indicates comment nesting level...
need to differentiate is/isn't dtd
Normal Int | DTD Int
then check in column 0 if it says '::'...
*/
......@@ -264,4 +264,4 @@ where
content_size fm {node_size_list}
# lh = fontLineHeight fm
= lh * (1+length node_size_list) + fm.fLeading// omdat we altijd totaal laten zien...
\ No newline at end of file
......@@ -36,7 +36,15 @@ import StdSystem
trace_n _ f :== f
//--
import Directory
ensureDirectory pd_string env
# ((ok,path),env) = pd_StringToPath pd_string env
| not ok
= (ok,env)
# (err_code, env) = createDirectory path env
= (err_code==NoDirError || err_code==AlreadyExists, env)
//import dodebug
Start :: !*World -> *World
Start world
# (stup,world) = accFiles GetFullApplicationPath world
......@@ -44,16 +52,27 @@ Start world
(mEdUndoId,world) = openId world
(mMdEdOptId,world) = openId world
// check for PrefsDir existence here...
// check for EnvsDir existence here...
// check for TooltempDir existence here...
# (ok,world) = ensureDirectory PrefsDir world
| not ok
= abort ("Missing directory for preferences:\n" +++ PrefsDir +++ "\nUnable to create it.\n")
# (ok,world) = ensureDirectory EnvsDir world
| not ok
= abort ("Missing directory for preferences:\n" +++ PrefsDir +++ "\nUnable to create it.\n")
# (ok,world) = ensureDirectory TempDir world
| not ok
= abort ("Missing directory for preferences:\n" +++ PrefsDir +++ "\nUnable to create it.\n")
# prefspath = MakeFullPathname PrefsDir PrefsFileName
#! (prefs,world) = openPrefs prefspath world
# envspath = MakeFullPathname EnvsDir EnvsFileName
#! (iniTargets,world)
= openEnvironments stup envspath world
#! (iniTargets,world) = openEnvironments stup envspath world
// # envspath = EnvsDir
// # (iniTargets,world) = getEnvironments stup envspath world
// # world = trace_n` ("entries",listToString entries) world
// #! (iniTargets,world)
// = openEnvironments stup envspath world
# (ffind,world) = initFindBoxInfo prefs world
# (iniTwi,world) = iniTypeWinInfo mEditId mEdUndoId ([]) prefs.typ_prefs world
......@@ -94,6 +113,7 @@ Start world
world
# patt = [ ProcessClose (Quit prefspath)
, ProcessOpenFiles openfiles
// , ProcessActivate (trace_n` "ACTIVATE!")
// , ProcessClipboardChanged clip_changed
: toolbar
] ++ PlatformProcessAttributes
......@@ -297,8 +317,8 @@ fileMenu prefspath {mn_clo,mn_sva,mn_sav,mn_rev,mn_oth,mn_prt,mn_prs,mn_odm,mn_o
[ MenuFunction (noLS ed_print_all)
]
:+: MenuSeparator []
:+: FileHistMenu "Recent Files" 12 mFileId fhRecId mFhMenId (StrictListToList prefs.file_hist) (\s->ed_open_cont s (\_ _ -> id))
:+: FileHistMenu "Recent Projects" 12 mFileId phRecId mPhMenId (StrictListToList prefs.proj_hist) pmopen
:+: FileHistMenu "Recent Files" 12 mFileId fhRecId mFhMenId (StrictListToList prefs.file_hist) fhopen
:+: FileHistMenu "Recent Projects" 12 mFileId phRecId mPhMenId (StrictListToList prefs.proj_hist) phopen
:+: MenuSeparator []
:+: MenuItem "&Quit"
[ MenuShortKey 'Q'
......@@ -317,9 +337,16 @@ where
= (ls,ps)
# ps = pm_new ps
= (ls,ps)
pmopen pathName ps
# (ok,ps) = pm_switch pathName ps
= ps
fhopen pathName ps
= ed_open_cont pathName cont ps
where
cont _ _ ps
# (_,ps) = syncSend2 fhRecId pathName ps
= ps
phopen pathName ps
= pm_open_path pathName ps
// # (ok,ps) = pm_switch pathName ps
// = ps
searchMenu altgr_workaround mSearchId {srchIds,findIds,gotoIds,nextIds}
= Menu "&Search"
......@@ -409,6 +436,9 @@ projectMenu
, MenuId (projIds!!12)
, MenuSelectState Unable
]
:+: MenuItem "Project Defaults..."