Commit e1f4cd2d authored by Diederik van Arkel's avatar Diederik van Arkel
Browse files

cleanup for Clean2 release

parent af9b4495
definition module PmPrefs
/*
The IDE Preferences
*/
// The IDE Preferences
from StdPictureDef import :: FontDef
import StdFile, StdIOBasic
......@@ -90,6 +88,21 @@ PrefsFileName :== "IDEPrefs"
, be_verbose :: !Bool // give extended diagnostics
, altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts...
, newline_handling :: !NewlinePrefs
, reg_prefs :: !RegPrefs
}
:: RegPrefs =
{ rp_flags :: ![(String,String,String)]
// should use registry entries for the following instead of Prefs file...
, tp_name :: !String
, tp_path :: !String
, hp_name :: !String
, hp_path :: !String
, pr_name :: !String
, pr_path :: !String
, ve_name :: !String
, ve_path :: !String
}
:: NewlinePrefs
......
......@@ -85,9 +85,20 @@ PrefsFileName :== "IDEPrefs"
, be_verbose :: !Bool // give extended diagnostics
, altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts...
, newline_handling :: !NewlinePrefs
// RWS ...
// , number_of_processes :: !Int
// ... RWS
, reg_prefs :: !RegPrefs
}
:: RegPrefs =
{ rp_flags :: ![(String,String,String)]
, tp_name :: !String
, tp_path :: !String
, hp_name :: !String
, hp_path :: !String
, pr_name :: !String
, pr_path :: !String
, ve_name :: !String
, ve_path :: !String
}
:: NewlinePrefs
......@@ -120,8 +131,21 @@ emptyPrefs =
, be_verbose = False
, altgr_workaround = False
, newline_handling = LeaveAlone NewlineConventionNone
, reg_prefs = emptyRegPrefs
}
emptyRegPrefs =
{ rp_flags = []
, tp_name = "ShowTimeProfile.exe"
, tp_path = "C:\\CLEAN\\TOOLS\\TIMEPR~1\\"
, hp_name = "ShowHeapProfile.exe"
, hp_path = "C:\\CLEAN\\TOOLS\\HEAPPR~1\\"
, pr_name = "Sparkle.exe"
, pr_path = "C:\\CLEAN\\TOOLS\\SPARKLE\\"
, ve_name = ""
, ve_path = ""
}
emptyTypPrefs =
{ typewinfont = NonProportionalFontDef
, typewinpos = {vx=30,vy=30}
......@@ -354,6 +378,7 @@ PrefsOptionsTable =
, SimpleOption "BeVerbose" (\a->if a.be_verbose "1" "0") (\v a->{a & be_verbose=(if (v=="1") True False)})
, SimpleOption "AltGrWorkaround" (\a->if a.altgr_workaround "1" "0") (\v a->{a & altgr_workaround=(if (v=="1") True False)})
, SimpleOption "NewlineHandling" writeNLH readNLH
, GroupedOption "RegPrefs" RegPrefsOptionsTable (\a->a.reg_prefs) (\v a->{a & reg_prefs = v})
}
where
writeNLH {newline_handling}
......@@ -378,6 +403,28 @@ where
"A3" -> {a & newline_handling = AlwaysUse NewlineConventionDos}
_ -> {a & newline_handling = LeaveAlone NewlineConventionNone}
RegPrefsOptionsTable :: OptionsTable RegPrefs
RegPrefsOptionsTable =
{ ListOption "ClideFlags" FlagOption ("","","") (\a->ListToStrictList a.rp_flags) (\v a->{a & rp_flags=StrictListToList v})
, SimpleOption "TimepName" (\a->a.tp_name) (\v a->{a & tp_name=v})
, SimpleOption "TimepPath" (\a->a.tp_path) (\v a->{a & tp_path=v})
, SimpleOption "HeappName" (\a->a.hp_name) (\v a->{a & hp_name=v})
, SimpleOption "HeappPath" (\a->a.hp_path) (\v a->{a & hp_path=v})
, SimpleOption "ProofName" (\a->a.pr_name) (\v a->{a & pr_name=v})
, SimpleOption "ProofPath" (\a->a.pr_path) (\v a->{a & pr_path=v})
, SimpleOption "VisedName" (\a->a.ve_name) (\v a->{a & ve_name=v})
, SimpleOption "VisedPath" (\a->a.ve_path) (\v a->{a & ve_path=v})
}
FlagOption = GroupedOption "Flags" FlagsOptionsTable id const
FlagsOptionsTable :: OptionsTable (String,String,String)
FlagsOptionsTable =
{ SimpleOption "fName" (\(a,_,_)->a) (\v (a,b,c)->(v,b,c))
, SimpleOption "fPath" (\(_,a,_)->a) (\v (a,b,c)->(a,v,c))
, SimpleOption "fVers" (\(_,_,a)->a) (\v (a,b,c)->(a,b,v))
}
ErrPrefsOptionsTable :: OptionsTable ErrPrefs
ErrPrefsOptionsTable =
{ GroupedOption "EWPos" VectOptionsTable (\a->a.err_pos) (\v a->{a & err_pos=v})
......
......@@ -839,8 +839,7 @@ ReadProjectFile projectPath applicationDir ps
(id)
) project // DvA: need to set needs save flag for project;
/*
Mooier is om ipv bovenstaande een dialoogje te laten zien met popupje met mogelijke environments.
Plus button om in htmlHelp in relevante sectie over environments te komen.
It's better to replace above with a dialog with popup of available environments.
*/
project = SetProject applicationDir projectDir project
execpath = PR_GetExecPath project
......@@ -849,7 +848,7 @@ Plus button om in htmlHelp in relevante sectie over environments te komen.
(closed, ps) = fclose file ps
| not closed
// generate warning?
= ((project, True,"The file \"" +++ projectName +++ "\" clould not be closed."), ps)
= ((project, True,"The file \"" +++ projectName +++ "\" could not be closed."), ps)
= ((project, True,""), ps)
getStaticInfo :: !Project -> (ProjectStaticInfo,Project)
......
definition module PmTypes
/* The types for the Project Manager */
// The types for the Project Manager
from StdPathname import :: Pathname
from UtilNewlinesFile import :: NewlineConvention(..)
import PmCompilerOptions
from UtilStrictLists import :: List
import UtilDate
from StdPathname import :: Pathname
from UtilNewlinesFile import :: NewlineConvention(..)
import PmCompilerOptions
from UtilStrictLists import :: List
import UtilDate
:: Modulename :== String
......@@ -35,7 +34,7 @@ instance fromString Processor
DefaultLinkOptions :: LinkOptions
:: LinkMethod
:: LinkMethod // => is really project method/type now?
= LM_Static
// | LM_Eager
| LM_Dynamic
......
implementation module PmTypes
/* The types for the Project Manager */
// The types for the Project Manager
import StdBool, StdInt
import UtilStrictLists, UtilDate
......
module first_run
implementation module first_run
import StdEnv, StdMaybe, StdDebug
import StdEnv, StdMaybe
import StdDebug
import registry, version
import UtilIO
import dodebug
//==
......@@ -15,18 +15,40 @@ GetLastError = code {
}
//==
GetVNP :: (String,String,String)
GetVNP = (app_vers,app_name,app_path)
where
path = winGetModulePath
long_path = GetLongPathName path
app_name = GetFileName long_path
app_path = GetFilePath path
app_vers = ReadVersionInfo
//==
Start w = startIO NDI Void pinit [ProcessClose closeProcess] w
Start`` w = startIO NDI Void pinit [ProcessClose closeProcess] w
pinit ps
# ps = first_run app_vers app_path app_name ps
# ((flag_name,flag_path,flag_vers),ps) = read_version_flag ps
# flags = [(flag_name,flag_path,flag_vers)]
# (res,ps) = first_run ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path flags ps
# ps = case res of
True -> write_version_flag (ide_name,ide_path,ide_vers) ps
_ -> ps
= finish ps
where
app_name = GetFileName long_path
app_path = GetFilePath path
app_vers = ReadVersionInfo
path = winGetModulePath
long_path= GetLongPathName path
path = winGetModulePath
long_path = GetLongPathName path
// ide_name = GetFileName long_path
// ide_path = GetFilePath path
ide_name = "CleanIDE.exe"
ide_path = "C:\\CLEAN\\"
ide_vers = ReadVersionInfo
pcl_name = "ShowTimeProfile.exe"
pcl_path = "C:\\CLEAN\\TOOLS\\TIMEPR~1\\"
hcl_name = "ShowHeapProfile.exe"
hcl_path = "C:\\CLEAN\\TOOLS\\HEAPPR~1\\"
GetFileName :: !String -> String;
GetFileName path
......@@ -101,7 +123,7 @@ ReadVersionInfo
# sptr = s2i buff
# slen = s2i blen
// # info = toString sptr +++ " :: " +++ toString slen
# info = {read_char p \\ p <- [sptr..] & x <- [1..slen]}
# info = {read_char p \\ p <- [sptr..] & x <- [1..slen-1]}
= info
where
path = winGetModulePath+++."\0"
......@@ -111,114 +133,124 @@ where
//==
MyEntry :== 1
NoEntry :== 2
DiffEntry :== 3
:: CheckResult
= MyEntry
| NoEntry
| DiffEntry
| ErrEntry !String
Yes :== 1
No :== 2
Never :== 3
:: DialogResult
= Yes
| No
| Never
first_run app_vers app_path app_name ps
# (run,ps) = check_flag app_vers app_path app_name ps
first_run :: !String !String !String !String !String !String !String ![(String,String,String)] !(PSt .ls) -> (!Bool,!PSt .ls)
first_run ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path flags ps
# (run,ps) = check_flags ide_vers ide_path ide_name flags ps
| not run
= ps
# (res,ps) = check_registry app_path ps
| res == MyEntry
= ps
| res == NoEntry
# (res,ps) = init_dialog ps
| res == Yes
# ps = set_registry app_name app_path ps
= ps
| res == No
= ps
| res == Never
# ps = set_flag app_vers app_path app_name ps
= ps
= abort "Uncaught case in first_run:first_run: [2]\n"
| res == DiffEntry
# (res,ps) = delta_dialog ps
| res == Yes
# ps = set_registry app_name app_path ps
= ps
| res == No
= ps
| res == Never
# ps = set_flag app_vers app_path app_name ps
= ps
= abort "Uncaught case in first_run:first_run: [3]\n"
= abort "Uncaught case in first_run:first_run: [1]\n"
uninstall application_path ps
= abort "first_run:uninstall unimplemented.\n"
= (False,ps)
# (res,ps) = check_registry ide_name ide_path ide_vers ps
= case res of
MyEntry -> (False,ps)
NoEntry
# (res,ps) = init_dialog ps
-> case res of
Yes # (err,ps) = set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
| err <> ""
# ps = err_dialog False err ps
= (False,ps)
= (False,ps)
No -> (False,ps)
Never -> (True,ps)
DiffEntry
# (res,ps) = delta_dialog ps
-> case res of
Yes # (err,ps) = set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
| err <> ""
# ps = err_dialog False err ps
= (False,ps)
= (False,ps)
No -> (False,ps)
Never -> (True,ps)
ErrEntry err
# ps = err_dialog True err ps
= (False,ps)
uninstall :: !(PSt .ls) -> (![String],!PSt .ls)
uninstall ps
# (e,rs) = ([],0)
# (e,rs) = remove_file_type_from_registry ".icl\0" "iclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".dcl\0" "dclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".prj\0" "prjfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".abc\0" "abcfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".pcl\0" "pclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".hcl\0" "hclfile\0" "open\0" e rs
# (e,rs) = remove_ide_from_registry e rs
= (e,ps)
//==
check_flag app_vers app_path app_name ps
// read flag => flag+vers+path+name
// compare...
// if vers & path & name match => use flag
// otherwise run first-run
# (ok,file,ps) = fopen "VERSION.txt" FReadText ps
read_version_flag ps
# (ok,file,ps) = fopen "VERSION.txt" FReadText ps
| not ok = abort "no VERSION"
# (flag_vers,file) = freadline file
# (flag_name,file) = freadline file
# (flag_path,file) = freadline file
# flag_vers = dropnl flag_vers
# flag_name = dropnl flag_name
# flag_path = dropnl flag_path
# (_,ps) = fclose file ps
| app_vers == flag_vers && app_path == flag_path && app_name == flag_name
= trace_n` "check=>False" (False,ps)
= trace_n` "check=>True" (True,ps)
# flag_vers = dropnl flag_vers
# flag_name = dropnl flag_name
# flag_path = dropnl flag_path
# (_,ps) = fclose file ps
= ((flag_name,flag_path,flag_vers),ps)
where
flag_vers = "2.0.1.42\0"
flag_name = "first_run.exe"
flag_path = "C:\\CLEANTOOLS\\REGISTRY\\"
dropnl s = {c \\ c <-: s | c <> '\xA' && c <> '\xD'}
set_flag app_vers app_path app_name ps
# ps = trace_n` ("set",app_vers,app_path,app_name) ps
# (ok,file,ps) = fopen "VERSION.txt" FWriteText ps
write_version_flag (flag_name,flag_path,flag_vers) ps
# (ok,file,ps) = fopen "VERSION.txt" FWriteText ps
| not ok = abort "set failed"
# file = writeln app_vers file
# file = writeln app_name file
# file = writeln app_path file
# (_,ps) = fclose file ps
# file = writeln flag_vers file
# file = writeln flag_name file
# file = writeln flag_path file
# (_,ps) = fclose file ps
= ps
where
writeln s f = f <<< s <<< '\n'
check_registry app_path ps
# (err,rs) = ([],7)
# (err,found,rs) = check_file_type_in_registry registry_name command err rs
| notEmpty err
= abort (hd err +++. "\n") ///////////////!!!!!!!!!!!!!!!!!!!!!
| found == ""
check_flags :: !String !String !String ![(String,String,String)] !(PSt .l) -> (!Bool,!PSt .l)
check_flags _ _ _ [] ps = (True,ps)
check_flags app_vers app_path app_name [(flag_name,flag_path,flag_vers):flags] ps
| app_vers == flag_vers && app_path == flag_path && app_name == flag_name
= (False,ps)
= check_flags app_vers app_path app_name flags ps
check_registry :: !String !String !String !(PSt .l) -> (!CheckResult,!PSt .l)
check_registry app_name app_path app_vers ps
# (name,path,vers,errs) = get_ide_from_registry
| notEmpty errs
= (NoEntry,ps)
# mine = quoted app_path
| found <> mine
| name <> app_name || path <> app_path || vers <> app_vers
= (DiffEntry,ps)
= (MyEntry,ps)
where
registry_name = "iclfile\0"
command = "open\0"
quoted string = "\"" +++ string +++ "\" \"%1\""
set_registry app_name app_path ps
# err = change_ide_registry_fun app_name app_path
# err = change_pcl_registry_fun app_name app_path pcl_name pcl_path
# err = change_hcl_registry_fun app_name app_path hcl_name hcl_path
set_registry :: !String !String !String !String !String !String !String !(PSt .l) -> (!String,!PSt .l)
set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
# (err,r) = enter_ide_in_registry (ide_name+++"\0") (ide_path+++"\0") (ide_vers+++"\0") [] 7
| notEmpty err || r <> 7
= (hd err,ps)
# err = change_ide_registry_fun ide_name ide_path
| notEmpty err
= abort (hd err +++. "\n") ///////////////!!!!!!!!!!!!!!!!!!!!!
= ps
= (hd err,ps)
# err = change_pcl_registry_fun ide_name ide_path pcl_name pcl_path
| notEmpty err
= (hd err,ps)
# err = change_hcl_registry_fun ide_name ide_path hcl_name hcl_path
| notEmpty err
= (hd err,ps)
= ("",ps)
import StdIO
init_dialog :: !(PSt .l) -> (!Int,!PSt .l)
init_dialog :: !(PSt .l) -> (!DialogResult,!PSt .l)
init_dialog ps
# (okId,ps) = openId ps
# (cancelId,ps) = openId ps
......@@ -227,7 +259,8 @@ init_dialog ps
| err <> NoError || isNothing res
= (No,ps)
= (fromJust res,ps)
delta_dialog :: !(PSt .l) -> (!Int,!PSt .l)
delta_dialog :: !(PSt .l) -> (!DialogResult,!PSt .l)
delta_dialog ps
# (okId,ps) = openId ps
# (cancelId,ps) = openId ps
......@@ -284,6 +317,26 @@ ddef okId cancelId dialogId = Dialog "Ide Integration"
]
dfun ret dId (_,ps)
= (ret,closeWindow dId ps)
err_dialog wasChecking err ps
# (okId,ps) = openId ps
# (dlogId,ps) = openId ps
# (_,ps) = openModalDialog Void
( Dialog (if wasChecking "Check Registry Failed!" "Setting Registry Failed!")
( edef okId dlogId)
[ WindowOk okId
, WindowId dlogId
]
) ps
= ps
where
edef okId dlogId
= TextControl (if wasChecking "Checking the windows registry failed:" "Setting the windows registry failed:")
[ ControlPos (Left,zero)
]
:+: TextControl err [ControlPos (Left,zero)]
:+: ButtonControl "OK" [ControlPos (Right,zero),ControlId okId,ControlFunction (noLS (closeWindow dlogId))]
//==
Start`
......@@ -313,6 +366,8 @@ import code from "cCrossCall_121.obj", "cCrossCallProcedureTable_121.obj", "cAcc
"util_121.obj"
import code from library "userExt_library"
// from clCCall_12.dcl...
winGetModulePath :: {#Char}
winGetModulePath
= code
......@@ -346,14 +401,12 @@ where
check :: !Int !RegistryKey !Bool !RegistryState -> (![String],!String,!RegistryState)
check hkey [] is_a_string rs
# data = createArray 256 '@'
# size = "\0\1\0\0"
# size = {c \\ c <-: "\0\1\0\0"}
# (r,rs) = if is_a_string
(RegQueryValueEx hkey "\0" 0 0 data size rs)
(RegQueryValueEx hkey "EditFlags\0" 0 0 data size rs)
| r<>ERROR_SUCCESS
= (["RegQueryValueEx failed\n"], "", rs)
// # rs = trace_n ("data: "+++.data) rs
// # rs = trace_n ("size: "+++. (convert size)) rs
# size = convert2 size
# value = data%(0,size-2)
= ([],value,rs)
......@@ -362,7 +415,7 @@ where
| r<>ERROR_SUCCESS
# (r,hkey2,rs) = RegOpenKeyEx hkey path 0 (KEY_READ bitor KEY_SET_VALUE) rs
| r<>ERROR_SUCCESS
= abort "RegOpenKeyEx failed\n" // 1
= (["RegOpenKeyEx failed\n"], "", rs)
# (e,r,rs) = check hkey2 path_list is_a_string rs
# (_,rs) = RegCloseKey hkey2 rs
= (e,r,rs)
......@@ -390,16 +443,7 @@ convert2 s
, hcl :: !Bool
}
remStart
# (e,rs) = ([],0)
# (e,rs) = remove_file_type_from_registry ".icl\0" "iclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".dcl\0" "dclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".prj\0" "prjfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".abc\0" "abcfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".pcl\0" "pclfile\0" "open\0" e rs
# (e,rs) = remove_file_type_from_registry ".hcl\0" "hclfile\0" "open\0" e rs
= e
change_hcl_registry_fun :: !String !String !String !String -> [String]
change_hcl_registry_fun ide_name ide_path hcl_name hcl_path
# (e,rs) = ([],0)
# (e,rs) = enter_file_type_in_registry hclMapping e rs
......@@ -417,6 +461,7 @@ where
}
application = StripExtension hcl_name +++. "\0"
change_pcl_registry_fun :: !String !String !String !String -> [String]
change_pcl_registry_fun ide_name ide_path pcl_name pcl_path
# (e,rs) = ([],0)
# (e,rs) = enter_file_type_in_registry pclMapping e rs
......@@ -496,7 +541,31 @@ where
, fm_application :: !String // application name [NULL-terminated]
, fm_icon :: !Maybe !String // resource identifier string [NULL-terminated]
}
enter_ide_in_registry name path vers e rs
# (e,rs) = add_to_registry ["Software\0","Clean\0"] "\0" True e rs
# (e,rs) = add_to_registry ["Software\0","Clean\0","CleanIDE\0"] "\0" True e rs
# (e,rs) = add_to_registry ["Software\0","Clean\0","CleanIDE\0","Name\0"] name True e rs
# (e,rs) = add_to_registry ["Software\0","Clean\0","CleanIDE\0","Path\0"] path True e rs
# (e,rs) = add_to_registry ["Software\0","Clean\0","CleanIDE\0","Vers\0"] vers True e rs
= (e,rs)
remove_ide_from_registry e rs
# (e,rs)=remove_from_registry ["Software\0","Clean\0","CleanIDE\0","Name\0"] e rs
# (e,rs)=remove_from_registry ["Software\0","Clean\0","CleanIDE\0","Path\0"] e rs
# (e,rs)=remove_from_registry ["Software\0","Clean\0","CleanIDE\0","Vers\0"] e rs
# (e,rs)=remove_from_registry ["Software\0","Clean\0","CleanIDE\0"] e rs
# (e,rs)=remove_from_registry ["Software\0","Clean\0"] e rs
= (e,rs)
get_ide_from_registry :: (!String,!String,!String,![String])
get_ide_from_registry
# rs = 7
# (nerr,name,rs) = check_registry_key ["Software\0","Clean\0","CleanIDE\0","Name\0"] rs
# (perr,path,rs) = check_registry_key ["Software\0","Clean\0","CleanIDE\0","Path\0"] rs
# (verr,vers,rs) = check_registry_key ["Software\0","Clean\0","CleanIDE\0","Vers\0"] rs
= (name,path,vers,nerr++perr++verr)
enter_file_type_in_registry :: !FileMapping [String] !RegistryState -> (![String],!RegistryState)
enter_file_type_in_registry fm e rs
# (e,rs) = add_to_registry p1 fm.fm_registry_name True e rs
......@@ -575,14 +644,14 @@ add_to_registry` hkey1 [] value value_is_a_string rs
(RegSetValueEx hkey1 "\0" 0 REG_SZ value (size value) rs)