Skip to content

GitLab

Commit 079ce4c4 authored by Diederik van Arkel's avatar Diederik van Arkel
Browse files

no message

parent 0427b8b5
Hide whitespace changes
Inline Side-by-side
Showing with 50 additions and 2223 deletions
BatchBuild.prj
View file @ 079ce4c4
......@@ -39,12 +39,13 @@ Global
Paths
Path: {Project}
Path: {Project}\BatchBuild
Path: {Application}\Directory
Path: {Application}\ArgEnvWindows
Path: {Project}\Pm
Path: {Project}\Util
Path: {Project}\Win
Path: {Project}\Interfaces\LinkerInterface
Path: {Project}\Win\PatchConsoleEvents
Path: {Project}\Win\ArgEnvWindows
Path: {Project}\Win\Directory
Precompile:
Postlink:
MainModule
......
BatchBuild/IdeState.dcl
View file @ 079ce4c4
......@@ -3,12 +3,12 @@ definition module IdeState
import StdPSt, StdId, StdPictureDef
import StdPathname
import UtilStrictLists
from PmAbcMagic import ABCCache
from PmProject import Project
from PmAbcMagic import :: ABCCache
from PmProject import :: Project
import PmCompilerOptions
import typewin
import PmEnvironment
from PmFileInfo import FileInfoCache
from PmFileInfo import :: FileInfoCache
:: *General
......@@ -58,6 +58,7 @@ getCurrentObjts :: !*(PSt *General) -> (!(List String),!*PSt *General)
getCurrentComp :: !*(PSt *General) -> (!String,!*PSt *General)
getCurrentCgen :: !*(PSt *General) -> (!String,!*PSt *General)
getCurrentLink :: !*(PSt *General) -> (!String,!*PSt *General)
getCurrentDynl :: !*(PSt *General) -> (!String,!*PSt *General)
getCurrentVers :: !*(PSt *General) -> (!Int,!*PSt *General)
getCurrentMeth :: !*(PSt *General) -> (!CompileMethod,!*PSt *General)
......
BatchBuild/IdeState.icl
View file @ 079ce4c4
......@@ -3,14 +3,13 @@ implementation module IdeState
import StdPSt, StdId, StdPictureDef, StdMisc, StdList, StdProcess, StdPStClass
import StdPathname
import UtilStrictLists
from PmAbcMagic import ABCCache, AC_Init
from PmProject import Project, PR_GetTarget
from PmAbcMagic import :: ABCCache, AC_Init
from PmProject import :: Project, PR_GetTarget
import PmCompilerOptions
import typewin
import PmEnvironment
import logfile
import set_return_code
//import PmDriver
import PmFileInfo
:: *General =
......@@ -160,6 +159,11 @@ getCurrentLink ps
# (ct,ps) = accPLoc (\p=:{pm_targets,pm_curtarg}->(pm_targets!!pm_curtarg,p)) ps
= (ct.target_link,ps)
getCurrentDynl :: !*(PSt *General) -> (!String,!*PSt *General)
getCurrentDynl ps
# (ct,ps) = accPLoc (\p=:{pm_targets,pm_curtarg}->(pm_targets!!pm_curtarg,p)) ps
= (ct.target_dynl,ps)
getCurrentVers :: !*(PSt *General) -> (!Int,!*PSt *General)
getCurrentVers ps
# (ct,ps) = accPLoc (\p=:{pm_targets,pm_curtarg}->(pm_targets!!pm_curtarg,p)) ps
......
BatchBuild/messwin.dcl
View file @ 079ce4c4
definition module messwin
import StdString, StdPSt
from IdeState import General
from IdeState import :: General
:: Info
= Level1 String
......
BatchBuild/messwin.icl
View file @ 079ce4c4
implementation module messwin
import StdString, StdPSt, StdBool, StdList, StdFunc
from IdeState import General, writeLog
from IdeState import :: General, writeLog
:: Info
= Level1 String
......
Editor/EdClient.dcl
View file @ 079ce4c4
definition module EdClient
import EdMonad, EdState, EdCommon
from EdMessage import EditAction
from EdMessage import :: EditAction
sendToActiveWindow :: .(*(EditState,*PSt *b) -> *(.c,*(EditState,*PSt *b))) !*(PSt *b) -> *(Maybe .c,*PSt *b) | Editor b
......
Editor/EdCommon.dcl
View file @ 079ce4c4
definition module EdCommon
from StdPSt import PSt, IOSt
from EdState import Editor, EditorState
from EdMonad import EditMonad, StateM, EditState
from EdSelection import Selection, Position, ColumnNr, LineNr
from StdPSt import :: PSt
from EdState import class Editor, :: EditorState
from EdMonad import :: EditMonad, :: StateM, :: EditState
from EdSelection import :: Selection, :: Position
:: *PLocState :== MyEditorState
:: MyEditorState = MES EditorState
......
Editor/EdCommon.icl
View file @ 079ce4c4
implementation module EdCommon
from EdState import Editor, EditorState
from EdState import class Editor, :: EditorState
import EdMonad
:: *PLocState :== MyEditorState
......
Editor/EdEditMenu.dcl
View file @ 079ce4c4
......@@ -4,9 +4,8 @@
definition module EdEditMenu
from StdMenu import Menu, Title, MenuAttribute
from StdPSt import PSt, IOSt
from EdCommon import MyEditorState
from StdPSt import :: PSt
from EdCommon import :: MyEditorState
openEditMenu :: (PSt *MyEditorState) -> PSt *MyEditorState
Editor/EdFileMenu.dcl
View file @ 079ce4c4
......@@ -4,11 +4,9 @@
definition module EdFileMenu
from StdMenu import Menu, Title, MenuAttribute
from StdId import Id
from StdPSt import PSt, IOSt
from EdState import EditorState
from EdCommon import MyEditorState
from StdId import :: Id
from StdPSt import :: PSt
from EdCommon import :: MyEditorState
openFileMenu :: Id (PSt *MyEditorState) -> PSt *MyEditorState
Editor/EdOptionsMenu.dcl
View file @ 079ce4c4
......@@ -4,9 +4,8 @@
definition module EdOptionsMenu
from StdMenu import Menu, Title, MenuAttribute
from StdPSt import PSt, IOSt
from EdCommon import MyEditorState
from StdPSt import :: PSt
from EdCommon import :: MyEditorState
openOptionsMenu :: !(PSt *MyEditorState) -> PSt *MyEditorState
HeapProfile/ExtNotice.dcl deleted 100644 → 0
View file @ 0427b8b5
definition module ExtNotice
/*
0.0 [P88] The original notice class from the Object IO tutorial
1.0 [DvA] Modified for use with the new Clean IDE
2.0 [DvA] Added TimedNotice class
P88 = Peter Achten (peter88@cs.kun.nl)
DvA = Diederik van Arkel (diederik@cs.kun.nl)
*/
import StdWindow, StdTimerDef
:: Notice ls ps
= Notice [String] (NoticeButton *(ls,ps)) [NoticeButton *(ls,ps)]
:: NoticeButton ps
= NoticeButton String (IdFun ps)
instance Dialogs Notice
openNotice :: !(Notice .ls *(PSt .l)) !*(PSt .l) -> *PSt .l
okNotice text ps :== openNotice (Notice text (NoticeButton "OK" (\x->x)) []) ps
:: TimedNotice ls ps
= TimedNotice [String] TimerInterval (NoticeButton *(ls,ps)) [NoticeButton *(ls,ps)]
instance Dialogs TimedNotice
openTimedNotice :: !(TimedNotice .ls *(PSt .l)) !*(PSt .l) -> *PSt .l
okTimedNotice text time ps :== openTimedNotice (TimedNotice text time (NoticeButton "OK" (\x->x)) []) ps
HeapProfile/ExtNotice.icl deleted 100644 → 0
View file @ 0427b8b5
implementation module ExtNotice
import StdTuple, StdMisc, StdFunc
import StdId, StdPSt, StdWindow, StdTimer
:: Notice ls ps
= Notice [String] (NoticeButton *(ls,ps)) [NoticeButton *(ls,ps)]
:: NoticeButton ps
= NoticeButton String (IdFun ps)
instance Dialogs Notice
where
// openDialog :: .ls (Notice .ls (PSt .l)) (PSt .l) -> (!ErrorReport, !PSt .l)
openDialog ls notice ps
# (wId, ps) = accPIO openId ps
(okId,ps) = accPIO openId ps
= openDialog ls (noticeToDialog wId okId notice) ps
// openModalDialog :: .ls (Notice .ls (PSt .l)) (PSt .l) -> (!(!ErrorReport,!Maybe .ls),!PSt .l)
openModalDialog ls notice ps
# (wId, ps) = accPIO openId ps
(okId,ps) = accPIO openId ps
= openModalDialog ls (noticeToDialog wId okId notice) ps
// getDialogType :: (Notice .ls .ps) -> WindowType
getDialogType _
= "Notice"
openNotice :: !(Notice .ls *(PSt .l)) !*(PSt .l) -> *PSt .l
openNotice notice ps
= snd (openModalDialog undef notice ps)
//noticeToDialog :: Id Id !(Notice .ls (PSt .l)) -> Dialog
noticeToDialog wid okid (Notice texts ok buttons)
= Dialog "" (texts` :+: ok` :+: buttons`)
[ WindowId wid
, WindowOk okid
]
where
texts` = LayoutControl
( ListLS
[ TextControl text [ControlPos (Left,zero)]
\\ text <- texts
]
)
[ ControlHMargin 0 0
, ControlVMargin 0 0
, ControlItemSpace 3 3
]
ok` = noticebutton ok [ControlPos (Right,zero), ControlId okid]
buttons` = ListLS
[ noticebutton button [ControlPos (LeftOfPrev,zero)]
\\ button <- buttons
]
noticebutton (NoticeButton text f) atts
= ButtonControl text [ControlFunction f`:atts]
where
f` (ls,ps) = f (ls,closeWindow wid ps)
okNotice text ps :== openNotice (Notice text (NoticeButton "OK" (\x->x)) []) ps
:: TimedNotice ls ps
= TimedNotice [String] TimerInterval (NoticeButton *(ls,ps)) [NoticeButton *(ls,ps)]
instance Dialogs TimedNotice
where
// openDialog :: .ls (TimedNotice .ls (PSt .l)) (PSt .l) -> (!ErrorReport, !PSt .l)
openDialog ls notice ps
# (wId, ps) = accPIO openId ps
(okId,ps) = accPIO openId ps
= openDialog ls (timednoticeToDialog wId okId notice) ps
// openModalDialog :: .ls (TimedNotice .ls (PSt .l)) (PSt .l) -> (!(!ErrorReport,!Maybe .ls),!PSt .l)
openModalDialog ls notice ps
# (wId, ps) = accPIO openId ps
(okId,ps) = accPIO openId ps
= openModalDialog ls (timednoticeToDialog wId okId notice) ps
// getDialogType :: (TimedNotice .ls .ps) -> WindowType
getDialogType _
= "TimerNotice"
openTimedNotice :: !(TimedNotice .ls *(PSt .l)) !*(PSt .l) -> *PSt .l
openTimedNotice notice ps
= snd (openModalDialog undef notice ps)
//timednoticeToDialog :: Id Id !(TimedNotice .ls (PSt .l)) -> Dialog
timednoticeToDialog wid okid (TimedNotice texts time ok buttons)
= Dialog "" (texts` :+: ok` :+: buttons`)
[ WindowId wid
, WindowOk okid
, WindowInit (noLS timestuff)
]
where
timestuff ps
# (err,ps) = openTimer undef timer` ps
| err <> NoError
# ps = okNotice ["Timer Creation Failed"] ps
# ps = closeWindow wid ps
= ps
= ps
texts` = LayoutControl
( ListLS
[ TextControl text [ControlPos (Left,zero)]
\\ text <- texts
]
)
[ ControlHMargin 0 0
, ControlVMargin 0 0
, ControlItemSpace 3 3
]
ok` = noticebutton ok [ControlPos (Right,zero), ControlId okid]
buttons` = ListLS
[ noticebutton button [ControlPos (LeftOfPrev,zero)]
\\ button <- buttons
]
timer` = Timer time NilLS [TimerFunction (\_ (ls,ps)->(ls,closeWindow wid ps))]
noticebutton (NoticeButton text f) atts
= ButtonControl text [ControlFunction f`:atts]
where
f` (ls,ps) = f (ls,closeWindow wid ps)
okTimedNotice text time ps :== openTimedNotice (TimedNotice text time (NoticeButton "OK" (\x->x)) []) ps
HeapProfile/expand_8_3_names_in_path.dcl deleted 100644 → 0
View file @ 0427b8b5
definition module expand_8_3_names_in_path;
expand_8_3_names_in_path :: !{#Char} -> {#Char};
HeapProfile/expand_8_3_names_in_path.icl deleted 100644 → 0
View file @ 0427b8b5
implementation module expand_8_3_names_in_path;
import StdEnv;
FindFirstFile :: !String -> (!Int,!String);
FindFirstFile file_name
# find_data = createArray 318 '\0';
# handle = FindFirstFile_ file_name find_data;
= (handle,find_data);
FindFirstFile_ :: !String !String -> Int;
FindFirstFile_ file_name find_data
= code {
ccall FindFirstFileA@8 "Pss:I"
}
FindClose :: !Int -> Int;
FindClose handle = code {
ccall FindClose@4 "PI:I"
}
find_null_char_in_string :: !Int !String -> Int;
find_null_char_in_string i s
| i<size s && s.[i]<>'\0'
= find_null_char_in_string (i+1) s;
= i;
find_data_file_name find_data
# i = find_null_char_in_string 44 find_data;
= find_data % (44,i-1);
find_first_file_and_close :: !String -> (!Bool,!String);
find_first_file_and_close file_name
# (handle,find_data) = FindFirstFile file_name;
| handle <> (-1)
# r = FindClose handle;
| r==r
= (True,find_data);
= (False,find_data);
= (False,"");
find_last_backslash_in_string i s
| i<0
= (False,-1);
| s.[i]=='\\'
= (True,i);
= find_last_backslash_in_string (i-1) s;
expand_8_3_names_in_path :: !{#Char} -> {#Char};
expand_8_3_names_in_path path_and_file_name
# (found_backslash,back_slash_index) = find_last_backslash_in_string (size path_and_file_name-1) path_and_file_name;
| not found_backslash
= path_and_file_name;
# path = expand_8_3_names_in_path (path_and_file_name % (0,back_slash_index-1));
# file_name = path_and_file_name % (back_slash_index+1,size path_and_file_name-1);
# path_and_file_name = path+++"\\"+++file_name;
# (ok,find_data) = find_first_file_and_close (path_and_file_name+++"\0");
| ok
= path+++"\\"+++find_data_file_name find_data;
= path_and_file_name;
HeapProfile/flexwin.dcl deleted 100644 → 0
View file @ 0427b8b5
definition module flexwin
import StdEnv, StdIO
//import ShowProfile
//:: FlexBarWindow ls pst = FlexBarWindow Title [(String, Maybe Int)] [WindowAttribute *(ls,pst)]
//:: FlexBarWindow ls pst
// = FlexBarWindow Title [(String, Maybe Int)] .[FormattedProfile] (R2Id (MessageIn ls) MessageOut) [WindowAttribute *(ls,pst)]
//:: FlexBarWindow s ls pst
// = FlexBarWindow Title [(String, Maybe Int)] [s] (R2Id (MessageIn s) MessageOut) [WindowAttribute *(ls,pst)]
class content_size c :: FontMetrics c -> Int
::FlexBarState s
:: FlexBarWindow s ls pst
= FlexBarWindow Title [(String, Maybe Int)] s
(!s .Int .Int [.Int] -> (.SelectState .UpdateState -> .(*Picture -> *Picture)))
![(FlexBarState s) -> FlexBarState s]
(R2Id (MessageIn s) (MessageOut s)) [WindowAttribute *(ls,pst)]
:: MessageIn s
= FW_DummyIn
| FW_SetContent s //[.FormattedProfile]
| FW_ApplyFunction Int
| FW_GetContent
:: MessageOut s
= FW_DummyOut
| FW_ContentOut s
instance Windows (FlexBarWindow s) | content_size s
//--
appInfo :: (s->s) !(FlexBarState s) -> FlexBarState s
HeapProfile/flexwin.icl deleted 100644 → 0
View file @ 0427b8b5
implementation module flexwin
/* TO DO:
o Content look
o Always leave first char of header string? Use clipping?
o Polling for column widths (in order to save/restore)
o Optimize setControlLook
o Button functions + header & body look updates...
o Sensible size handling
*/
import StdEnv, StdIO
import StdDebug
import ioutil
class content_size c :: FontMetrics c -> Int
:: FlexBarState s =
{ nrOfColumns :: !Int
, columnPoss :: ![Int]
, columnTexts :: ![String]
, height :: !Int
, windowId :: !Id
, headerId :: !Id
, receiverId :: !R2Id (MessageIn s) (MessageOut s)
, cursep :: !Int // selected column seperator ~1 if none
, curcol :: !Int // selected column 0 if none negative if selected but mouse outside of button area
, domain :: !ViewDomain
, info :: !s
, line_height :: !Int
, metrics :: !FontMetrics
, columnFuncs :: ![(FlexBarState s) -> FlexBarState s]
, body_look :: !s .Int .Int [.Int] -> (.SelectState .UpdateState -> .(*Picture -> *Picture))
}
:: MessageIn s
= FW_DummyIn
| FW_SetContent s
| FW_ApplyFunction Int
| FW_GetContent
:: MessageOut s
= FW_DummyOut
| FW_ContentOut s
mi2cw Nothing = 10
mi2cw (Just w)
| w < 5 = 5 // minimum column width, moet eigenlijk niet hier maar pas bij tekenen en afhankelijk van font
= w
//--
:: FlexBarWindow s ls pst = FlexBarWindow Title [(String, Maybe Int)] s (!s .Int .Int [.Int] -> (.SelectState .UpdateState -> .(*Picture -> *Picture))) ![(FlexBarState s) -> FlexBarState s] (R2Id (MessageIn s) (MessageOut s)) [WindowAttribute *(ls,pst)]
instance Windows (FlexBarWindow s) | content_size s
where
getWindowType _ = "FlexBarWindow"
openWindow ls (FlexBarWindow title elts info look funs receiverId atts) ps
# (windowId,ps) = case hasWindowIdAtt of
Nothing -> openId ps
(Just wId) -> (wId,ps)
# (headerId,ps) = openId ps
# ((ok,font),ps) = accScreenPicture (openFont {fName="Courier New", fStyles=[BoldStyle],fSize=8}) ps
# (metrics,ps) = accScreenPicture (getFontMetrics font) ps
# ((size,line_height),ps) = accScreenPicture (profileSize info o (setPenFont font)) ps
# domain = {zero & corner2 = {x=last columnPoss,y=height + size}}
= openWindow
(newstate info domain line_height metrics headerId windowId)
(Window title (header info domain line_height metrics font headerId windowId) (newatts info domain font size line_height metrics headerId windowId)) ps
where
hasWindowIdAtt
# los = filter (isWindowId) atts
| isEmpty los = Nothing
= Just (getWindowIdAtt (hd los))
header info domain line_height metrics font headerId windowId
= CustomControl
{w=4096,h=height} // zinniger maximum invullen???
(headerLook height columnTexts columnPoss`)
[ControlId headerId
,ControlMouse mouseFilter Able (mouseFunction (newstate info domain line_height metrics headerId windowId))
,ControlPos (Fix,OffsetFun 1 (\({corner1={x}},{y})->{vx = x,vy = y}))
,ControlPen [PenFont font]
]
:+: Receiver2 receiverId receiver []
newatts info domain font size line_height metrics headerId windowId =
[ WindowPen [PenBack Vellum, PenFont font]
, WindowLook True (flexLook (newstate info domain line_height metrics headerId windowId))
, WindowViewDomain domain
, WindowId windowId
, WindowMouse mouseFilter Able (mouseFunction (newstate info domain line_height metrics headerId windowId))
, WindowKeyboard keyboardFilter Able (keyboardFunction)
, WindowHScroll (myScrollFunction Horizontal LR_STEP)
, WindowVScroll (myScrollFunction Vertical line_height)
, WindowClose (noLS closeProcess)
: fixwinatts atts
]
newstate info domain line_height metrics headerId windowId =
{ nrOfColumns = length elts
, columnPoss = columnPoss
, columnTexts = columnTexts
, height = height
, metrics = metrics
, line_height = line_height
, windowId = windowId
, headerId = headerId
, receiverId = receiverId
, cursep = ~1
, curcol = 0
, domain = domain
, info = info
, columnFuncs = funs
, body_look = look
}
height = 20
columnPoss = fiddle 0 (map (mi2cw o snd) elts) []
columnPoss` = [0:columnPoss]
columnTexts = map fst elts
appInfo :: (s->s) !(FlexBarState s) -> FlexBarState s
appInfo f fs=:{info} = {fs & info = f info}
//--
LR_STEP :== 12
keyboardFilter (SpecialKey key (KeyDown _) _)
| key == upKey = True
| key == downKey = True
| key == beginKey = True
| key == endKey = True
| key == pgUpKey = True
| key == pgDownKey = True
| key == leftKey = True
| key == rightKey = True
= False
keyboardFilter _ = False
keyboardFunction (SpecialKey key _ mods) (fs=:{windowId,height,line_height,domain,columnPoss},ps)
# (delta,ps) = calcDelta ps
| delta == zero
= (fs,ps)
# ps = appPIO (moveWindowViewFrame windowId delta) ps
= (fs,ps)
where