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

cleanup for Clean2 release

parent af9b4495
definition module PmPrefs definition module PmPrefs
/* // The IDE Preferences
The IDE Preferences
*/
from StdPictureDef import :: FontDef from StdPictureDef import :: FontDef
import StdFile, StdIOBasic import StdFile, StdIOBasic
...@@ -90,6 +88,21 @@ PrefsFileName :== "IDEPrefs" ...@@ -90,6 +88,21 @@ PrefsFileName :== "IDEPrefs"
, be_verbose :: !Bool // give extended diagnostics , be_verbose :: !Bool // give extended diagnostics
, altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts... , altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts...
, newline_handling :: !NewlinePrefs , 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 :: NewlinePrefs
......
...@@ -85,9 +85,20 @@ PrefsFileName :== "IDEPrefs" ...@@ -85,9 +85,20 @@ PrefsFileName :== "IDEPrefs"
, be_verbose :: !Bool // give extended diagnostics , be_verbose :: !Bool // give extended diagnostics
, altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts... , altgr_workaround :: !Bool // temp fix to workaround french azerty keyboard menu shortcuts...
, newline_handling :: !NewlinePrefs , newline_handling :: !NewlinePrefs
// RWS ...
// , number_of_processes :: !Int , reg_prefs :: !RegPrefs
// ... RWS }
:: 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 :: NewlinePrefs
...@@ -120,8 +131,21 @@ emptyPrefs = ...@@ -120,8 +131,21 @@ emptyPrefs =
, be_verbose = False , be_verbose = False
, altgr_workaround = False , altgr_workaround = False
, newline_handling = LeaveAlone NewlineConventionNone , 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 = emptyTypPrefs =
{ typewinfont = NonProportionalFontDef { typewinfont = NonProportionalFontDef
, typewinpos = {vx=30,vy=30} , typewinpos = {vx=30,vy=30}
...@@ -354,6 +378,7 @@ PrefsOptionsTable = ...@@ -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 "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 "AltGrWorkaround" (\a->if a.altgr_workaround "1" "0") (\v a->{a & altgr_workaround=(if (v=="1") True False)})
, SimpleOption "NewlineHandling" writeNLH readNLH , SimpleOption "NewlineHandling" writeNLH readNLH
, GroupedOption "RegPrefs" RegPrefsOptionsTable (\a->a.reg_prefs) (\v a->{a & reg_prefs = v})
} }
where where
writeNLH {newline_handling} writeNLH {newline_handling}
...@@ -378,6 +403,28 @@ where ...@@ -378,6 +403,28 @@ where
"A3" -> {a & newline_handling = AlwaysUse NewlineConventionDos} "A3" -> {a & newline_handling = AlwaysUse NewlineConventionDos}
_ -> {a & newline_handling = LeaveAlone NewlineConventionNone} _ -> {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 :: OptionsTable ErrPrefs
ErrPrefsOptionsTable = ErrPrefsOptionsTable =
{ GroupedOption "EWPos" VectOptionsTable (\a->a.err_pos) (\v a->{a & err_pos=v}) { GroupedOption "EWPos" VectOptionsTable (\a->a.err_pos) (\v a->{a & err_pos=v})
......
...@@ -839,8 +839,7 @@ ReadProjectFile projectPath applicationDir ps ...@@ -839,8 +839,7 @@ ReadProjectFile projectPath applicationDir ps
(id) (id)
) project // DvA: need to set needs save flag for project; ) 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. It's better to replace above with a dialog with popup of available environments.
Plus button om in htmlHelp in relevante sectie over environments te komen.
*/ */
project = SetProject applicationDir projectDir project project = SetProject applicationDir projectDir project
execpath = PR_GetExecPath project execpath = PR_GetExecPath project
...@@ -849,7 +848,7 @@ Plus button om in htmlHelp in relevante sectie over environments te komen. ...@@ -849,7 +848,7 @@ Plus button om in htmlHelp in relevante sectie over environments te komen.
(closed, ps) = fclose file ps (closed, ps) = fclose file ps
| not closed | not closed
// generate warning? // 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) = ((project, True,""), ps)
getStaticInfo :: !Project -> (ProjectStaticInfo,Project) getStaticInfo :: !Project -> (ProjectStaticInfo,Project)
......
definition module PmTypes definition module PmTypes
/* The types for the Project Manager */ // The types for the Project Manager
from StdPathname import :: Pathname
from StdPathname import :: Pathname from UtilNewlinesFile import :: NewlineConvention(..)
from UtilNewlinesFile import :: NewlineConvention(..) import PmCompilerOptions
import PmCompilerOptions from UtilStrictLists import :: List
from UtilStrictLists import :: List import UtilDate
import UtilDate
:: Modulename :== String :: Modulename :== String
...@@ -35,7 +34,7 @@ instance fromString Processor ...@@ -35,7 +34,7 @@ instance fromString Processor
DefaultLinkOptions :: LinkOptions DefaultLinkOptions :: LinkOptions
:: LinkMethod :: LinkMethod // => is really project method/type now?
= LM_Static = LM_Static
// | LM_Eager // | LM_Eager
| LM_Dynamic | LM_Dynamic
......
implementation module PmTypes implementation module PmTypes
/* The types for the Project Manager */ // The types for the Project Manager
import StdBool, StdInt import StdBool, StdInt
import UtilStrictLists, UtilDate import UtilStrictLists, UtilDate
......
module first_run implementation module first_run
import StdEnv, StdMaybe, StdDebug import StdEnv, StdMaybe
import StdDebug
import registry, version import registry, version
import UtilIO import UtilIO
import dodebug
//== //==
...@@ -15,18 +15,40 @@ GetLastError = code { ...@@ -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 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 = finish ps
where where
app_name = GetFileName long_path path = winGetModulePath
app_path = GetFilePath path long_path = GetLongPathName path
app_vers = ReadVersionInfo // ide_name = GetFileName long_path
path = winGetModulePath // ide_path = GetFilePath path
long_path= GetLongPathName 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 :: !String -> String;
GetFileName path GetFileName path
...@@ -101,7 +123,7 @@ ReadVersionInfo ...@@ -101,7 +123,7 @@ ReadVersionInfo
# sptr = s2i buff # sptr = s2i buff
# slen = s2i blen # slen = s2i blen
// # info = toString sptr +++ " :: " +++ toString slen // # 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 = info
where where
path = winGetModulePath+++."\0" path = winGetModulePath+++."\0"
...@@ -111,114 +133,124 @@ where ...@@ -111,114 +133,124 @@ where
//== //==
MyEntry :== 1 :: CheckResult
NoEntry :== 2 = MyEntry
DiffEntry :== 3 | NoEntry
| DiffEntry
| ErrEntry !String
Yes :== 1 :: DialogResult
No :== 2 = Yes
Never :== 3 | No
| Never
first_run app_vers app_path app_name ps first_run :: !String !String !String !String !String !String !String ![(String,String,String)] !(PSt .ls) -> (!Bool,!PSt .ls)
# (run,ps) = check_flag app_vers app_path app_name ps 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 | not run
= ps = (False,ps)
# (res,ps) = check_registry app_path ps # (res,ps) = check_registry ide_name ide_path ide_vers ps
| res == MyEntry = case res of
= ps MyEntry -> (False,ps)
| res == NoEntry NoEntry
# (res,ps) = init_dialog ps # (res,ps) = init_dialog ps
| res == Yes -> case res of
# ps = set_registry app_name app_path ps Yes # (err,ps) = set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
= ps | err <> ""
| res == No # ps = err_dialog False err ps
= ps = (False,ps)
| res == Never = (False,ps)
# ps = set_flag app_vers app_path app_name ps No -> (False,ps)
= ps Never -> (True,ps)
= abort "Uncaught case in first_run:first_run: [2]\n" DiffEntry
| res == DiffEntry # (res,ps) = delta_dialog ps
# (res,ps) = delta_dialog ps -> case res of
| res == Yes Yes # (err,ps) = set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
# ps = set_registry app_name app_path ps | err <> ""
= ps # ps = err_dialog False err ps
| res == No = (False,ps)
= ps = (False,ps)
| res == Never No -> (False,ps)
# ps = set_flag app_vers app_path app_name ps Never -> (True,ps)
= ps ErrEntry err
= abort "Uncaught case in first_run:first_run: [3]\n" # ps = err_dialog True err ps
= abort "Uncaught case in first_run:first_run: [1]\n" = (False,ps)
uninstall application_path ps uninstall :: !(PSt .ls) -> (![String],!PSt .ls)
= abort "first_run:uninstall unimplemented.\n" 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_version_flag ps
// read flag => flag+vers+path+name # (ok,file,ps) = fopen "VERSION.txt" FReadText ps
// compare...
// if vers & path & name match => use flag
// otherwise run first-run
# (ok,file,ps) = fopen "VERSION.txt" FReadText ps
| not ok = abort "no VERSION" | not ok = abort "no VERSION"
# (flag_vers,file) = freadline file # (flag_vers,file) = freadline file
# (flag_name,file) = freadline file # (flag_name,file) = freadline file
# (flag_path,file) = freadline file # (flag_path,file) = freadline file
# flag_vers = dropnl flag_vers # flag_vers = dropnl flag_vers
# flag_name = dropnl flag_name # flag_name = dropnl flag_name
# flag_path = dropnl flag_path # flag_path = dropnl flag_path
# (_,ps) = fclose file ps # (_,ps) = fclose file ps
| app_vers == flag_vers && app_path == flag_path && app_name == flag_name = ((flag_name,flag_path,flag_vers),ps)
= trace_n` "check=>False" (False,ps)
= trace_n` "check=>True" (True,ps)
where 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'} dropnl s = {c \\ c <-: s | c <> '\xA' && c <> '\xD'}
set_flag app_vers app_path app_name ps write_version_flag (flag_name,flag_path,flag_vers) ps
# ps = trace_n` ("set",app_vers,app_path,app_name) ps # (ok,file,ps) = fopen "VERSION.txt" FWriteText ps
# (ok,file,ps) = fopen "VERSION.txt" FWriteText ps
| not ok = abort "set failed" | not ok = abort "set failed"
# file = writeln app_vers file # file = writeln flag_vers file
# file = writeln app_name file # file = writeln flag_name file
# file = writeln app_path file # file = writeln flag_path file
# (_,ps) = fclose file ps # (_,ps) = fclose file ps
= ps = ps
where where
writeln s f = f <<< s <<< '\n' writeln s f = f <<< s <<< '\n'
check_registry app_path ps check_flags :: !String !String !String ![(String,String,String)] !(PSt .l) -> (!Bool,!PSt .l)
# (err,rs) = ([],7) check_flags _ _ _ [] ps = (True,ps)
# (err,found,rs) = check_file_type_in_registry registry_name command err rs check_flags app_vers app_path app_name [(flag_name,flag_path,flag_vers):flags] ps
| notEmpty err | app_vers == flag_vers && app_path == flag_path && app_name == flag_name
= abort (hd err +++. "\n") ///////////////!!!!!!!!!!!!!!!!!!!!! = (False,ps)
| found == "" = 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) = (NoEntry,ps)
# mine = quoted app_path | name <> app_name || path <> app_path || vers <> app_vers
| found <> mine
= (DiffEntry,ps) = (DiffEntry,ps)
= (MyEntry,ps) = (MyEntry,ps)
where
registry_name = "iclfile\0"
command = "open\0"
quoted string = "\"" +++ string +++ "\" \"%1\""
set_registry app_name app_path ps set_registry :: !String !String !String !String !String !String !String !(PSt .l) -> (!String,!PSt .l)
# err = change_ide_registry_fun app_name app_path set_registry ide_vers ide_name ide_path pcl_name pcl_path hcl_name hcl_path ps
# err = change_pcl_registry_fun app_name app_path pcl_name pcl_path # (err,r) = enter_ide_in_registry (ide_name+++"\0") (ide_path+++"\0") (ide_vers+++"\0") [] 7
# err = change_hcl_registry_fun app_name app_path hcl_name hcl_path | notEmpty err || r <> 7
= (hd err,ps)
# err = change_ide_registry_fun ide_name ide_path
| notEmpty err | notEmpty err
= abort (hd err +++. "\n") ///////////////!!!!!!!!!!!!!!!!!!!!! = (hd err,ps)
= 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 import StdIO
init_dialog :: !(PSt .l) -> (!Int,!PSt .l) init_dialog :: !(PSt .l) -> (!DialogResult,!PSt .l)
init_dialog ps init_dialog ps
# (okId,ps) = openId ps # (okId,ps) = openId ps
# (cancelId,ps) = openId ps # (cancelId,ps) = openId ps
...@@ -227,7 +259,8 @@ init_dialog ps ...@@ -227,7 +259,8 @@ init_dialog ps
| err <> NoError || isNothing res | err <> NoError || isNothing res
= (No,ps) = (No,ps)
= (fromJust res,ps) = (fromJust res,ps)
delta_dialog :: !(PSt .l) -> (!Int,!PSt .l)
delta_dialog :: !(PSt .l) -> (!DialogResult,!PSt .l)
delta_dialog ps delta_dialog ps
# (okId,ps) = openId ps # (okId,ps) = openId ps
# (cancelId,ps) = openId ps # (cancelId,ps) = openId ps
...@@ -284,6 +317,26 @@ ddef okId cancelId dialogId = Dialog "Ide Integration" ...@@ -284,6 +317,26 @@ ddef okId cancelId dialogId = Dialog "Ide Integration"
] ]
dfun ret dId (_,ps) dfun ret dId (_,ps)
= (ret,closeWindow 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` Start`
...@@ -313,6 +366,8 @@ import code from "cCrossCall_121.obj", "cCrossCallProcedureTable_121.obj", "cAcc ...@@ -313,6 +366,8 @@ import code from "cCrossCall_121.obj", "cCrossCallProcedureTable_121.obj", "cAcc
"util_121.obj" "util_121.obj"
import code from library "userExt_library" import code from library "userExt_library"
// from clCCall_12.dcl...