implementation module IDE import StdArray, StdEnum, StdFunc, StdMisc, StdTuple, StdOrdList import StdFileSelect,StdMenu,StdMenuReceiver,StdProcess, StdPStClass import ExtNotice import UtilIO import PmDialogues import PmParse import PmPath from EdKeyMapping import macKeyMapping, ReadKeyMapFile, KeyMapFileName from finder import sr_find, sr_find_next, sr_find_sel, sr_rep_find, sr_goto_cursor, sr_goto_line, sr_goto_selection from edoptions import defaultFontAndTabs, optionsKeyMapping, editColours from EdClient import :: EditAction, isEditWin, msgGetPathName,msgSelectAll, emptySelection, sendToActiveWindow, msgGetSelection, msgUndo,msgPaste,msgCopy,msgCut,msgClear,msgBalance,msgDetab import prefix, tools import IdeState import ideoptions import clipboard,typewin,idehelp,PmEnvironment,search import errwin, messwin, projwin, edfiles import projmen, filehist, ioutil, menubar from PmDirCache import SearchDisk,FindHModule import targetui from PmCleanSystem import QuitCleanCompiler import Platform,PlatformObjectIO, IdePlatform import PmDriver import StdSystem, StdClipboard //trace_n m f :== trace_n` m f 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) Start :: !*World -> *World Start world # (stup,world) = accFiles GetFullApplicationPath world (mEditId,world) = openId world (mEdUndoId,world) = openId world (mMdEdOptId,world) = openId world # (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 environments:\n" +++ EnvsDir +++ "\nUnable to create it.\n") # (ok,world) = ensureDirectory TempDir world | not ok = abort ("Missing directory for temporary files:\n" +++ TempDir +++ "\nUnable to create it.\n") # prefspath = MakeFullPathname PrefsDir PrefsFileName #! (prefs,world) = openPrefs prefspath world # envspath = MakeFullPathname EnvsDir EnvsFileName #! (iniTargets,world) = openEnvironments stup envspath world # (ffind,world) = initFindBoxInfo prefs world # (iniTwi,world) = iniTypeWinInfo mEditId mEdUndoId ([]) prefs.typ_prefs world // Win only? # (iniCons,world) = iniConsWinInfo mEditId mEdUndoId ([]) prefs.con_prefs world #! (lbId,world) = openExtListBoxId world #! (mTargetId,world) = openId world (eTargetId,world) = openId world (mProjectId,world) = openId world (mPrListId,world) = openId world #! (mPrRecId,world) = openR2Id world # (toolbar,world) = setupToolBar prefs.show_toolbar world # (keymap,world) = setupKeyMap world # emptyFindInfo = { fi_find = [], fi_repl = [], fi_ic = False, fi_wa = True , fi_bw = False, fi_mw = False, fi_re=False } # (interact, force_update, proj_path, logfile, world) = batchOptions world #! (iniClip,pub,world) = iniGeneral prefs stup interact logfile mTargetId eTargetId lbId (initEditorState keymap) emptyFindInfo ffind mEdUndoId mMdEdOptId iniTwi // winOnly? iniCons iniTargets mProjectId mPrListId mPrRecId world # patt = [ ProcessClose (Quit prefspath) , ProcessOpenFiles openfiles // , ProcessClipboardChanged clip_changed : toolbar ] ++ PlatformProcessAttributes #! (ids,world) = openIds 7/*8*/ world # (mFhMenId,world) = openId world (mPhMenId,world) = openId world pini = ini envspath prefspath mEditId mEdUndoId iniClip iniTargets mTargetId eTargetId mProjectId mPrListId mPrRecId mFhMenId mPhMenId ids | interact = startIO MDI pub pini patt world // not interact = Batch stup force_update proj_path pub world where setupKeyMap world # keymappath = MakeFullPathname PrefsDir KeyMapFileName # ((km,ok,_),world) = accFiles (ReadKeyMapFile keymappath) world # keymap = if ok km macKeyMapping = (keymap,world) setupToolBar show world // need to conditionalise for Mac... | not show = ([],world) # items = [] # (items,world) = toolIconFun srchBM (Just "Search...") (sr_find_idi True) items world # (items,world) = toolIconFun findBM (Just "Find...") sr_find items world # items = if (isEmpty items) [] [ToolbarSeparator:items] /* # (items,world) = toolIconFun execBM (Just "Run") pm_run items world */ # (items,world) = toolIconFun updtBM (Just "Update") (pm_upto False) items world # (items,world) = toolIconFun urunBM (Just "Update and Run") pm_exec items world # items = if (isEmpty items) [] [ToolbarSeparator:items] # (items,world) = toolIconFun prntBM (Just "Print...") ed_print items world # items = if (isEmpty items) [] [ToolbarSeparator:items] # (items,world) = toolIconFun saveBM (Just "Save") (ide_save NoModifiers) items world # (items,world) = toolIconFun openBM (Just "Open...") (ed_open NoModifiers) items world # (items,world) = toolIconFun newfBM (Just "New...") (ed_new "*.icl") items world | isEmpty items = ([],world) # toolbar = [ ProcessToolbar items] = (toolbar,world) ini envspath prefspath mEditId mEdUndoId iniClip iniTargets mTargetId eTargetId mProjectId mPrListId mPrRecId mFhMenId mPhMenId [ mFileId , mSearchId , mCommandsId , mOptionsId, mGoodiesId , mPrNewId, mPrOpenId // , quitId : _ ] ps # ps = PlatformInteractiveInit ps // can modify Prefs! # (prefs,ps) = getPrefs ps # (fhRecId,ps) = getFHI ps # (phRecId,ps) = getPHI ps # (menuIds,ps) = getMenuIds ps # (err,ps) = openMenu Void (fileMenu prefspath menuIds mPrNewId mFileId mFhMenId mPhMenId /*quitId*/ fhRecId phRecId prefs) ps | err <> NoError = abort "unable to open File menu" # (editRecId,ps)= getEditRecId ps # (err,ps) = openMenu iniEditLS (editMenu prefs.altgr_workaround mEditId editRecId menuIds.mn_sav menuIds.mn_rev menuIds iniClip) ps | err <> NoError = abort "unable to open Edit menu" # (err,ps) = openMenu Void (searchMenu prefs.altgr_workaround mSearchId menuIds.searchIds) ps | err <> NoError = abort "unable to open Search menu" # (err,ps) = openMenu Void (projectMenu mProjectId mPrOpenId mPrListId mPrRecId menuIds prefs) ps | err <> NoError = abort "unable to open Project menu" # (err,ps) = openMenu Void (moduleMenu menuIds) ps | err <> NoError = abort "unable to open Module menu" # (err,ps) = openMenu Void (optionsMenu mOptionsId) ps | err <> NoError = abort "unable to open Defaults menu" # (err,ps) = openMenu Void (targetMenu envspath iniTargets mTargetId eTargetId getTargets setTargets) ps | err <> NoError = abort "unable to open Environment menu" # ps = setProjectTarget (hd iniTargets).target_name ps # ps = pm_open_project_window ps # (wId,ps) = getPWW ps # ps = initHelpMenu wId ps # (twi,ps) = accPLoc getTypeWinInfo ps # twi = TW_SetUpd ([menuIds.mn_cut,menuIds.mn_pst,menuIds.mn_clr:menuIds.mg_edt]) twi # ps = appPLoc (setTypeWinInfo twi) ps # (files,ps) = initPlatformCommandLineArguments ps # ps = openfiles files ps # ps = SetProcessIcon CleanIcon ps = installPlatformEventHandlers ps ini _ _ _ _ _ _ _ _ _ _ _ _ _ _ ps = abort "IDE.icl: ini called with insufficient id's" fileMenu prefspath {mn_clo,mn_sva,mn_sav,mn_rev,mn_oth,mn_prt,mn_prs,mn_odm,mn_oim} mPrNewId mFileId mFhMenId mPhMenId /*quitId*/ fhRecId phRecId prefs # altgr_workaround = prefs.altgr_workaround = Menu "&File" ( MenuItem "&New File..." [ MenuShortKey 'N' , MenuModsFunction newffun ] :+: MenuItem "New Project..." [ MenuFunction (noLS pm_new) , MenuId mPrNewId ] :+: MenuItem "New Project Using Template..." [MenuFunction (noLS pm_new_project_using_template)] :+: MenuItem "&Open..." [ MenuShortKey 'O' , MenuModsFunction (noLS1 ed_open) ] :+: MenuItem "&Save" [ MenuShortKey 'S' , MenuModsFunction (noLS1 ide_save) , MenuId mn_sav ] :+: MenuItem "Save As..." [ MenuModsFunction (noLS1 ide_save_as) , MenuId mn_sva ] :+: MenuItem "Save All" [ MenuFunction (noLS ed_save_all) ] :+: MenuSeparator [] :+: MenuItem "&Revert" [ MenuFunction (noLS ed_revert) , MenuId mn_rev , MenuSelectState Unable ] :+: MenuItem "&Close" [ MenuShortKey 'W' , MenuId mn_clo , MenuSelectState Able , MenuModsFunction (noLS1 ide_menu_close) ] :+: MenuItem "Close All" [ MenuFunction (noLS ide_close_all) ] :+: MenuSeparator [] :+: MenuItem "Open Other" [ MenuFunction (noLS ed_open_other) , MenuId mn_oth , MenuSelectState Unable : if altgr_workaround [] [MenuShortKey '/'] ] :+: MenuItem "Open Definition..." [ MenuShortKey 'D' , MenuModsFunction (noLS1 (ed_open_sel False)) , MenuId mn_odm ] :+: MenuItem "Open Implementation..." [ MenuShortKey 'I' , MenuModsFunction (noLS1 (ed_open_sel True)) , MenuId mn_oim ] :+: MenuSeparator [] :+: MenuItem "Print Setup..." [ MenuId mn_prs , MenuFunction (noLS ed_print_setup) ] :+: MenuItem "&Print..." [ MenuShortKey 'P' , MenuFunction (noLS ed_print) , MenuId mn_prt , MenuSelectState Unable ] :+: MenuItem "Print All..." [ MenuFunction (noLS ed_print_all) ] :+: MenuSeparator [] :+: FileHistMenu "Recent Files" 12 mFileId fhRecId mFhMenId (StrictListToList prefs.file_hist) fhopen :+: FileHistMenu "Recent Projects" 12 mFileId phRecId mPhMenId (StrictListToList prefs.proj_hist) phopen :+: PlatformItem (PlatformDependant True (not onOSX)) ( MenuSeparator [] :+: MenuItem "&Quit" [ MenuShortKey 'Q' , MenuFunction (noLS (Quit prefspath)) // , MenuId (quitId) ] ) ) [ MenuId (mFileId) ] where newffun mods (ls,ps) | not mods.shiftDown # ps = case mods.altDown || mods.optionDown of True -> ed_new "*.dcl" ps False -> ed_new "*.icl" ps = (ls,ps) # ps = pm_new ps = (ls,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 :: PlatformItem m ls pst = PlatformItem Bool (m ls pst) instance MenuElements (PlatformItem m) | MenuElements m where menuElementToHandles (PlatformItem False _) pState = menuElementToHandles NilLS pState menuElementToHandles (PlatformItem True item) pState = menuElementToHandles item pState getMenuElementType _ = "PlatformItem" searchMenu altgr_workaround mSearchId {srchIds,findIds,gotoIds,nextIds} = Menu "&Search" ( MenuItem "&Find..." [ MenuId (findIds!!0), MenuShortKey 'F', MenuModsFunction findfun ] :+: MenuItem "Find &Next" [ MenuId (findIds!!1), MenuShortKey 'G', MenuModsFunction (shiftfun sr_find_next) ] :+: MenuItem "Find Selection" [ MenuId (findIds!!2), /*MenuShortKey 'H',*/ MenuModsFunction (shiftfun sr_find_sel) ] :+: MenuItem "Replace && Find Again" [ MenuId (findIds!!3), MenuShortKey 'T', MenuModsFunction (shiftfun sr_rep_find) ] :+: MenuSeparator [] :+: MenuItem "&Search Identifier" [ MenuId (srchIds!!0) , MenuModsFunction (shiftfun` sr_find_idi) : if altgr_workaround [] [MenuShortKey '='] ] :+: MenuItem "Search Definition" [ MenuId (srchIds!!1), MenuShortKey 'L', MenuModsFunction defimpfun ] :+: MenuItem "Search Implementation" [ MenuId (srchIds!!2), /*MenuShortKey 'M',*/ MenuModsFunction (shiftfun` sr_find_imp) ] :+: MenuSeparator [] :+: MenuItem "Goto Next Search &Result" [ MenuId (nextIds!!0) , MenuSelectState Unable , MenuModsFunction findresfun : if altgr_workaround [] [MenuShortKey ','] ] :+: MenuItem "Goto Next &Error" [ MenuId (nextIds!!1), MenuShortKey 'E', MenuSelectState Unable, MenuModsFunction finderrfun ] :+: MenuItem "Goto &Cursor" [ MenuId (gotoIds!!0), MenuFunction (noLS sr_goto_cursor) ] :+: MenuItem "Goto &Line..." [ MenuId (gotoIds!!1), MenuFunction (noLS sr_goto_line) ] :+: MenuItem "Goto Selection..." [ MenuId (gotoIds!!2), MenuFunction (noLS sr_goto_selection) ] ) [ MenuId (mSearchId) ] where findfun mods (ls,ps) # ps = flip_dir mods.shiftDown ps | mods.altDown || mods.optionDown # ps = sr_find_sel ps # ps = flip_dir mods.shiftDown ps = (ls,ps) # ps = sr_find ps # ps = flip_dir mods.shiftDown ps = (ls,ps) where flip_dir flip ps | not flip = ps # (fi,ps) = getFI ps # fi = {fi & fi_bw = not fi.fi_bw} # ps = setFI fi ps = ps defimpfun mods (ls,ps) | mods.altDown || mods.optionDown # ps = sr_find_imp mods.shiftDown ps = (ls,ps) # ps = sr_find_def mods.shiftDown ps = (ls,ps) shiftfun fun mods (ls,ps) | not mods.shiftDown # ps = fun ps = (ls,ps) # (fi,ps) = getFI ps # fi = {fi & fi_bw = not fi.fi_bw} # ps = setFI fi ps # ps = fun ps # (fi,ps) = getFI ps // so that we do get the modifications in find info from find selection... # fi = {fi & fi_bw = not fi.fi_bw} # ps = setFI fi ps = (ls,ps) shiftfun` fun mods (ls,ps) | not mods.shiftDown # ps = fun False ps = (ls,ps) # ps = fun True ps = (ls,ps) finderrfun mods (ls,ps) # ps = sr_find_err (not mods.shiftDown) ps = (ls,ps) findresfun mods (ls,ps) # ps = wind_next (not mods.shiftDown) ps = (ls,ps) projectMenu mProjectId mPrOpenId mPrListId mPrRecId {projIds} prefs = Menu "&Project" ( MenuItem "Bring &Up To Date" [ MenuShortKey 'U' , MenuModsFunction (shiftfun (noLS (pm_upto False)) (noLS (pm_upto True))) , MenuId (projIds!!3) , MenuSelectState Unable ] :+: MenuItem "Update and &Run" [ MenuShortKey 'R' , MenuModsFunction (shiftfun (noLS pm_exec) (noLS pm_run)) , MenuId (projIds!!4) , MenuSelectState Unable ] :+: MenuItem "Run" [ MenuFunction (noLS pm_run) , MenuId (projIds!!5) , MenuSelectState Unable ] :+: MenuSeparator [] :+: MenuItem "&Set Main Module" [ MenuFunction (noLS pm_set) , MenuId (projIds!!10) , MenuSelectState Unable ] :+: MenuItem "&Project Options..." [ MenuFunction (noLS projectOptions) , MenuId (projIds!!12) , MenuSelectState Unable ] :+: MenuItem "Project Directory Up" [MenuFunction (noLS project_directory_up)] :+: MenuItem "Project Directory Down" [MenuFunction (noLS project_directory_down)] :+: MenuItem "Save Project Template..." [MenuFunction (noLS pm_save_project_as_template)] :+: MenuItem "Project Defaults..." [ MenuFunction (noLS projectDefaults) ] :+: MenuSeparator [] :+: MenuItem "Show &Heap Profile" [ MenuFunction (noLS shoheapfun) , MenuId (projIds!!6) , MenuSelectState Unable ] :+: MenuItem "Show &Time Profile" [ MenuFunction (noLS shoprofun) , MenuId (projIds!!7) , MenuSelectState Unable ] :+: MenuItem "Theorem &Prover Project" [ MenuFunction (noLS provefun) , MenuId (projIds!!8) , MenuSelectState Unable ] // :+: MenuItem "Theorem Prover Module" // [ MenuSelectState Unable // , MenuId (projIds!!9) // ] :+: MenuSeparator [] :+: ProjListMenu mProjectId mPrListId mPrRecId ) [ MenuId mProjectId ] where shiftfun fun1 fun2 mods (ls,ps) | not mods.shiftDown = fun1 (ls,ps) = fun2 (ls,ps) moduleMenu {md_cmp,md_chk,md_gen,md_cst,md_est} = Menu "&Module" ( MenuItem "&Compile" [ MenuShortKey 'K' , MenuFunction (noLS pm_compile) , MenuId md_cmp , MenuSelectState Unable ] :+: MenuItem "Check Syntax" [ MenuShortKey 'Y' , MenuFunction (noLS pm_check) , MenuId md_chk , MenuSelectState Unable ] :+: MenuItem "Generate &Assembly" [ MenuFunction (noLS pm_gen_asm) , MenuId md_gen , MenuSelectState Unable ] :+: MenuSeparator [] :+: MenuItem "Module Options..." [ MenuFunction (noLS pm_copt) , MenuId md_cst , MenuSelectState Unable , MenuShortKey 'J' // 'Fix' ctrl-J -> newline bug. ] :+: MenuItem "Module Defaults..." [ MenuFunction (noLS pm_coprefs) ] /* :+: MenuItem "Editor Settings..." [ MenuShortKey 'J' , MenuFunction (noLS optionsFontAndTabs) , MenuId md_est , MenuSelectState Unable ] */ ) [] optionsMenu mOptionsId = Menu "&Defaults" ( SubMenu "Window Settings" ( MenuItem "Editor Colours..." [ MenuFunction (noLS editColours) ] :+: MenuItem "Editor Settings..." [ MenuFunction (noLS defaultFontAndTabs) ] :+: MenuItem "Project Window..." [ MenuFunction (noLS projwinOptions) ] :+: MenuItem "Types Window..." [ MenuFunction (noLS typewinColours) ] // winOnly? :+: MenuItem "Console Window..." [ MenuFunction (noLS conswinColours) ] // ... :+: MenuItem "Search Window..." [ MenuFunction (noLS src_options) ] :+: MenuItem "Error Window..." [ MenuFunction (noLS err_options) ] ) [] :+: MenuItem "Key Mapping..." [ MenuFunction (noLS optionsKeyMapping)] :+: MenuItem "IDE Options..." [ MenuFunction (noLS (ideOptionsDialog)) ] ) [ MenuId mOptionsId ] //-- openfiles [] ps = ps openfiles [file:files] ps # ps = ide_open file ps # ps = openfiles files ps = ps where ide_open :: !String !(PSt *General) -> (PSt *General) ide_open file ps | IsPrjPathname file = pm_open_path file ps = ed_open_path file ps //-- ed_open :: !Modifiers !(PSt *General) -> (PSt *General) ed_open {shiftDown} ps // ask user for a file to open # (maybeString, ps) = selectInputFile ps | isNothing maybeString = ps # pathname = fromJust maybeString // look if project; if so open as project | (IsPrjPathname pathname) && (not shiftDown) // if shift-down always open as text = pm_open_path pathname ps = ed_open_path pathname ps Quit :: !String !(PSt *General) -> (PSt *General) Quit prefspath ps = ed_ask_save_all True False cont ps where cont ps // save project # (prefs,ps) = getPrefs ps # (twi,ps) = accPLoc getTypeWinInfo ps // winOnly # (cwi,ps) = accPLoc getConsWinInfo ps # (errinf,ps) = getErrInfo ps # err_prefs = err_shut errinf # ((proj_pos,proj_siz),ps) = pm_get_projwin_possiz ps # (fbi,ps) = getFBI ps # srcfdef = getFontDef fbi.src_font # srcfname = srcfdef.fName # srcfsize = srcfdef.fSize # (fhId,ps) = getFHI ps # ((rep,file_hist),ps) = syncSend2 fhId "" ps # file_hist = if ((rep == SendOk) && isJust file_hist) (fromJust file_hist) [] # (phId,ps) = getPHI ps # ((rep,proj_hist),ps) = syncSend2 phId "" ps # proj_hist = if ((rep == SendOk) && isJust proj_hist) (fromJust proj_hist) [] # src_prefs = { src_pos = fbi.src_offset , src_siz = fbi.src_size , src_fname = srcfname , src_fsize = srcfsize , src_forc = fbi.src_forg , src_bacc = fbi.src_back } # prefs = { prefs & typ_prefs = TW_GetInf twi // winOnly , con_prefs = getConPrefs cwi , err_prefs = err_prefs , src_prefs = src_prefs , prj_prefs.proj_pos = proj_pos , prj_prefs.proj_siz = proj_siz , proj_hist = ListToStrictList proj_hist , file_hist = ListToStrictList file_hist } # ps = savePrefs prefspath prefs ps # ps = pm_save ps // macOnly? # (method,ps) = getCurrentMeth ps # use_compiler_process_ids = case method of CompileAsync _ -> True ; _ -> False # (compiler_process_ids,ps) = getCompilerProcessIds ps # ps = app_world_instead_of_ps (QuitCleanCompiler use_compiler_process_ids compiler_process_ids) ps = closeProcess ps //--- Window rotating nextWindow :: *(PSt .a) -> *PSt .a nextWindow ps # (stack,ps) = accPIO getWindowsStack ps | isEmpty stack = ps # [h:t] = stack | isEmpty t = ps # f = last t # new = hd t # ps = stackWindow h f ps # ps = setActiveWindow new ps = ps prevWindow :: *(PSt .a) -> *PSt .a prevWindow ps # (stack,ps) = accPIO getWindowsStack ps | isEmpty stack = ps # [_:t] = stack | isEmpty t = ps # f = last t # ps = setActiveWindow f ps = ps //--- editor routines ide_menu_close mods ps | mods.shiftDown = ide_close_all ps = ide_close ps ide_close ps # (mi,ps) = accPIO getActiveWindow ps | isNothing mi = ps # win = fromJust mi # (isEdit,ps) = isEditWin win ps | isEdit = ed_close win ps # (done,ps) = ew_maybe_close win ps | done = ps # (done,ps) = tw_maybe_close win ps | done = ps # (done,ps) = sw_maybe_close win ps | done = ps // still need to do message win... = ps ide_close_all pstate = ed_ask_save_all True True id pstate ide_save mods ps | mods.altDown || mods.optionDown = ide_save_as mods ps | mods.shiftDown = ed_save_all ps // also save project? # (mi,ps) = accPIO getActiveWindow ps | isNothing mi = ps # win = fromJust mi # (isEdit,ps) = isEditWin win ps | isEdit # (_,ps) = ed_save win ps = ps # (isProj,ps) = isProjWin win ps | isProj = pm_save ps = ps ide_save_as mods ps # (mi,ps) = accPIO getActiveWindow ps | isNothing mi = ps # win = fromJust mi # (isEdit,ps) = isEditWin win ps # (isProj,ps) = isProjWin win ps | mods.shiftDown | isEdit = ed_save_copy_as ps | isProj = pm_save_copy_as ps = ps | isEdit = ed_save_as ps | isProj = pm_save_as ps = ps //-- ed_open_sel openImp mods ps | mods.shiftDown = open_dlog ps # (wId,ps) = accPIO getActiveWindow ps | isNothing wId = open_dlog ps # wId = fromJust wId # (res,ps) = maybe_type_win_message wId msgGetSelection ps | isJust res # (sel,_) = fromJust res | sel == "" || not (is_h_module_name sel) = open_dlog ps = open_imp_or_def_module openImp sel ps # (msel,ps) = sendToActiveWindow msgGetSelection ps | isNothing msel = open_dlog ps # (sel,_) = fromJust msel | sel == "" || not (is_h_module_name sel) = open_dlog ps = open_imp_or_def_module openImp sel ps where open_imp_or_def_module openImp sel ps | openImp = open_imp_module sel ps = open_def_module sel ps open_dlog pstate # (dlogId,pstate) = openId pstate (textId,pstate) = openId pstate (okId,pstate) = openId pstate (cancelId,pstate) = openId pstate (_,pstate) = openModalDialog Void (dialog dlogId textId okId cancelId) pstate = pstate dialog dlogId textId okId cancelId = Dialog "Open Module" ( EditControl (if openImp ".icl" ".dcl") (PixelWidth 200) 1 [ ControlId textId , ControlKeyboard filterReturnKeys Able (\_ -> noLS (dfun True)) ] :+: ButtonControl "Cancel" [ ControlPos (Left,zero) , ControlFunction (noLS (closeWindow dlogId)) , ControlId cancelId , ControlWidth (ContentWidth "Cancel") ] :+: ButtonControl "OK" [ ControlFunction (noLS (dfun False)) , ControlId okId , ControlWidth (ContentWidth "Cancel") ] ) [ WindowId dlogId , WindowOk okId , WindowCancel cancelId , WindowClose (noLS (closeWindow dlogId)) ] where dfun strip ps # (wdef,ps) = accPIO (getWindow dlogId) ps | isNothing wdef = closeWindow dlogId ps // shouldn't be possible # wdef = fromJust wdef (ok,text) = getControlText textId wdef | not ok || isNothing text = closeWindow dlogId ps // shouldn't be possible # text = fromJust text #! ps = closeWindow dlogId ps # text = if strip {c \\ c <- [c \\ c <-: text | c <> '\n']} text = OpenModule text emptySelection ps ed_open_other pstate # (mpath,pstate) = sendToActiveWindow msgGetPathName pstate | isNothing mpath = pstate # path = fromJust mpath | IsDefPathname path # path = RemoveSuffix path path = MakeImpPathname path # (exists,pstate) = accFiles (FExists path) pstate | exists = ed_open_path path pstate | CleanModId (RemovePath (RemoveSuffix path)) = OpenModuleNoSel (RemovePath path) pstate = pstate | IsImpPathname path # path = RemoveSuffix path path = MakeDefPathname path # (exists,pstate) = accFiles (FExists path) pstate | exists = ed_open_path path pstate | CleanModId (RemovePath (RemoveSuffix path)) = OpenModuleNoSel (RemovePath path) pstate = pstate = pstate get_environment_and_project_paths :: !(*PSt General) -> (!List {#Char},!*PSt General) get_environment_and_project_paths ps # (syspaths,ps) = getCurrentPaths ps # (prj,ps) = getProject ps # prjpaths = PR_GetPaths prj = (AppendLists prjpaths syspaths, ps) OpenModuleNoSel pathname ps # (srcpaths,ps) = get_environment_and_project_paths ps # srcpaths = if (IsABCPathname pathname) (Map MakeSystemPathname srcpaths) srcpaths # ((ok,fullpath),ps) = accFiles (SearchDisk pathname srcpaths) ps | not ok = could_not_find_file_notice pathname ps # fullpath` = GetLongPathName fullpath = ed_open_path fullpath` ps n_chars_of_file_ext s # n=size s | n>3 && is_3_char_file_ext (s % (n-4,n-1)) = 4 | n>2 && is_2_char_file_ext (s % (n-3,n-1)) = 3 = 0 where is_3_char_file_ext ".icl" = True is_3_char_file_ext ".dcl" = True is_3_char_file_ext ".lhs" = True is_3_char_file_ext _ = False is_2_char_file_ext ".hs" = True is_2_char_file_ext _ = False split_string :: !Int !{#Char} -> (!{#Char},!{#Char}) split_string i s # n=size s # i=n-i = (s % (0,i-1),s % (i,n-1)) OpenModule :: !.Modulename !.Selection !*(PSt General) -> *PSt General OpenModule pathname sel ps # (srcpaths,ps) = get_environment_and_project_paths ps # srcpaths = if (IsABCPathname pathname) (Map MakeSystemPathname srcpaths) srcpaths # n=n_chars_of_file_ext pathname # ((ok,fullpath),ps) = if (n==0) (accFiles (SearchDisk pathname srcpaths) ps) (let (module_name,file_ext) = split_string n pathname in accFiles (FindHModule module_name file_ext srcpaths) ps) | not ok = could_not_find_file_notice pathname ps # fullpath` = GetLongPathName fullpath = ed_open_path_sel fullpath` sel ps open_def_module :: !Modulename !*(PSt General) -> *PSt General open_def_module pathname ps # module_name = RemoveSuffix pathname # (srcpaths,ps) = get_environment_and_project_paths ps # ((ok,fullpath),ps) = accFiles (FindHModule module_name ".dcl" srcpaths) ps | not ok = could_not_find_file_notice (module_name+++".dcl") ps # fullpath` = GetLongPathName fullpath = ed_open_path_sel fullpath` emptySelection ps open_imp_module :: !Modulename !*(PSt General) -> *PSt General open_imp_module pathname ps # module_name = RemoveSuffix pathname # (srcpaths,ps) = get_environment_and_project_paths ps # ((ok,fullpath),ps) = accFiles (FindHModule module_name ".icl" srcpaths) ps | ok = open_file fullpath ps | not ok = could_not_find_file_notice (module_name+++".icl") ps where open_file fullpath ps # fullpath` = GetLongPathName fullpath = ed_open_path_sel fullpath` emptySelection ps could_not_find_file_notice file_name ps = okNotice [ "Clean Project Manager" , "Could not find file:" , file_name ] ps //--- edit menu stuff iniEditLS = { zfun = ed_Undo , xfun = ed_Cut , cfun = ed_Copy , vfun = ed_Paste } recfun MGet (ls,ps) = (ls,(ls,ps)) recfun (MSet ss) (ls,ps) = (ss,(ss,ps)) editMenu altgr_workaround mEditId editRecId mFileSaveId mFileRevertId {mn_und, mn_cut, mn_cpy, mn_pst, mn_clr, mg_edt, searchIds} iniClip = Menu "&Edit" ( MenuItem "&Undo" [ MenuShortKey 'Z' , MenuFunction (\(ls=:{zfun},ps)->(ls,zfun ps)) , MenuSelectState Unable , MenuId mn_und ] :+: MenuItem "Cu&t" [ MenuShortKey 'X' , MenuFunction (\(ls=:{xfun},ps)->(ls,xfun ps)) , MenuId mn_cut ] :+: MenuItem "&Copy" [ MenuShortKey 'C' , MenuFunction (\(ls=:{cfun},ps)->(ls,cfun ps)) , MenuId mn_cpy ] :+: MenuItem "&Paste" [ MenuShortKey 'V' , MenuFunction (\(ls=:{vfun},ps)->(ls,vfun ps)) , MenuId mn_pst ] :+: Receiver2 editRecId recfun [] :+: MenuItem "Cl&ear" [ MenuId mn_clr, MenuFunction (noLS ed_Clear) ] :+: MenuSeparator [] :+: MenuItem "Shift &Left" [ MenuId (mg_edt!!0) , MenuFunction (noLS shift_selection_left) : if altgr_workaround [] [MenuShortKey '['] ] :+: MenuItem "Shift &Right" [ MenuId (mg_edt!!1) , MenuFunction (noLS shift_selection_right) : if altgr_workaround [] [MenuShortKey ']'] ] :+: MenuItem "&Balance" [ MenuId (mg_edt!!2), MenuShortKey 'B', MenuFunction (noLS ed_Balance)] :+: MenuItem "Select &All" [ MenuId (mg_edt!!3), MenuShortKey 'A', MenuFunction (noLS ed_SelectAll)] :+: MenuItem "&Detab" [ MenuId (mg_edt!!4), MenuFunction (noLS detabfun)] :+: MenuItem "Add Pre&fix" [ MenuId (mg_edt!!5), MenuFunction (noLS add_prefix_selection)] :+: MenuItem "Remove Pref&ix" [ MenuId (mg_edt!!6), MenuFunction (noLS rem_prefix_selection)] :+: MenuItem "Change Prefi&x..." [ MenuId (mg_edt!!7), MenuFunction (noLS change_prefix_dlog)] :+: MenuItem "I&ncrement Integers" [ MenuId (mg_edt!!8), MenuFunction (noLS increment_integers_in_selection)] :+: MenuItem "De&crement Integers" [ MenuId (mg_edt!!9), MenuFunction (noLS decrement_integers_in_selection)] :+: MenuSeparator [] :+: MenuItem "Next &Window" [ MenuModsFunction stackfun : if altgr_workaround [] [MenuShortKey '\\'] ] :+: clipMenuItems mFileSaveId mFileRevertId iniClip // Wrap... // :+: MenuItem "Wrap1320" [MenuShortKey '`', MenuFunction (noLS wrap_preprocessor)] // ...Wrap :+: MenuItem "List Defi&nitions..." [ MenuFunction (noLS popup_funs) : if altgr_workaround [] [MenuShortKey '`'] ] ) [ MenuId (mEditId) ] where stackfun mods (ls,ps) | mods.shiftDown = (ls,prevWindow ps) = (ls,nextWindow ps) detabfun ps // Add 'Are you sure dialog' ? # (_,ps) = sendToActiveWindow msgDetab ps = ps //-- ed_Undo ps # (_,ps) = sendToActiveWindow msgUndo ps = mb_update_undoinfo ps ed_Paste ps # (_,ps) = sendToActiveWindow msgPaste ps = mb_update_undoinfo ps ed_Copy ps # (res,ps) = sendToActiveWindow msgCopy ps | isNothing res # (isErrWin,ps) = ew_is_active ps | isErrWin # (errinf,ps) = getErrInfo ps # lbId = errinf.infoId # ((ok,sel),ps) = getFilteredListBoxSelection lbId ps | not ok = ps # sel = map fst sel # string = foldr (\l r->l+++"\n"+++r) "" sel # newclip = [toClipboard string] # ps = setClipboard newclip ps = ps # (win,ps) = accPIO (getActiveWindow) ps | isNothing win = ps # win = fromJust win # (_,ps) = maybe_type_win_message win msgCopy ps = mb_update_undoinfo ps = mb_update_undoinfo ps ed_Cut pstate # (res,pstate) = sendToActiveWindow msgCut pstate | isNothing res # (win,pstate) = accPIO (getActiveWindow) pstate | isNothing win = pstate # win = fromJust win # (_,pstate) = maybe_type_win_message win msgCopy pstate = mb_update_undoinfo pstate = mb_update_undoinfo pstate ed_Clear ps # (_,ps) = sendToActiveWindow msgClear ps = mb_update_undoinfo ps ed_SelectAll ps # (win,ps) = accPIO getActiveWindow ps # (isPrjWin,ps) = case win of Just wId -> isProjWin wId ps _ -> (False,ps) | isPrjWin # (lbId,ps) = getPWI ps # ps = setExtListBoxSelectionAll lbId ps = ps # (_,ps) = sendToActiveWindow msgSelectAll ps = mb_update_undoinfo ps ed_Balance ps # (_,ps) = sendToActiveWindow msgBalance ps = mb_update_undoinfo ps //== x-perimental import EdLineText, StrictList, EdClient popup_funs ps # (ret,ps) = sendToActiveWindow gettext ps | isNothing ret = ps # text = fromJust ret # text = textToStrings text # text = slToList text # text = {t \\ t <- text} # (defs,ps) = accFiles (FindDefinesInText text) ps # defs = cleanup defs # defs = purge_and_reverse [] defs # defs = sortBy sort defs # (_,ps) = openMenu Void (PopUpMenu (ListLS [toMenuItem d \\ d <- defs])) ps = ps where cleanup defs = case defs of [] -> [] [DefFun "definition" _:defs] -> cleanup defs [DefFun "implementation" _:defs] -> cleanup defs [DefFun "module" _:defs] -> cleanup defs [DefFun "system" _:defs] -> cleanup defs [def:defs] -> [def:cleanup defs] sort (DefType id1 _) (DefType id2 _) = id1 < id2 sort (DefType _ _) _ = True sort _ (DefType _ _) = False sort (DefClass id1 _) (DefClass id2 _) = id1 < id2 sort (DefClass _ _) _ = True sort _ (DefClass _ _) = False sort (DefInst cl1 id1 _)(DefInst cl2 id2 _) | cl1 == cl2 = id1 < id2 = cl1 < cl2 sort (DefInst _ _ _) _ = True sort _ (DefInst _ _ _) = False sort (DefGeneric id1 _) (DefGeneric id2 _) = id1 < id2 sort (DefGeneric _ _) _ = True sort _ (DefGeneric _ _) = False sort (DefDerive cl1 id1 _)(DefDerive cl2 id2 _) | cl1 == cl2 = id1 < id2 = cl1 < cl2 sort (DefDerive _ _ _) _ = True sort _ (DefDerive _ _ _) = False sort (DefFun id1 _) (DefFun id2 _) = id1 < id2 sort (DefFun _ _) _ = True sort _ (DefFun _ _) = False sort _ _ = abort "IDE:sort called with unknown constructor\n" toMenuItem (DefFun id ln) = MenuItem (id) [MenuFunction (menfun ln)] toMenuItem (DefType id ln) = MenuItem (":: "+++.id) [MenuFunction (menfun ln)] toMenuItem (DefClass id ln) = MenuItem ("class "+++.id) [MenuFunction (menfun ln)] toMenuItem (DefInst cl id ln) = MenuItem ("instance "+++.cl+++." "+++.id) [MenuFunction (menfun ln)] toMenuItem (DefGeneric id ln) = MenuItem ("generic "+++.id) [MenuFunction (menfun ln)] toMenuItem (DefDerive cl id ln) = MenuItem ("derive "+++.cl+++." "+++.id) [MenuFunction (menfun ln)] menfun ln (ls,ps) # (_,ps) = sendToActiveWindow (msgScrollToLine ln) ps = (ls,ps) gettext = getText >>>= \text -> return text purge_and_reverse :: [Def] [Def] -> [Def] purge_and_reverse acc [] = acc purge_and_reverse [] [h:t] = purge_and_reverse [h] t purge_and_reverse [a=:(DefFun an al):as] [d=:(DefFun dn dl):ds] | an==dn | al
>>= \text -> getSelection >>>= \selection -> getNeedSave >>>= \needsave -> IF (isEmptySelection selection) THEN ( skip ) ELSE ( let orderedSelection = orderSelection selection (ofragment, _) = getTextFragment orderedSelection text fragment = if (slLast ofragment == "") (slInit ofragment) ofragment nfragment = slAppend (slAppend (SCons "//1.3" fragment) (SCons "//3.1" (SCons "/*2.0" fragment))) (SCons "0.2*/" (SCons "" SNil)) position = orderedSelection.start newPosition = newCursorPos position nfragment in vDoCursorSafe ( vRemoveSelection >>> mRemoveSelection >>> vInsertText position nfragment >>> vChangeSelectionTo {start=newPosition,end=newPosition} >>> mChangeSelectionTo {start=newPosition,end=newPosition} >>> vCenterCursor ) >>> setNeedSave True >>> setUndoInfo { state = Undo , action = " Wrap" , uninfo = PasteInfo nfragment ofragment selection position needsave } ) where newCursorPos :: !Position !TextFragment -> Position newCursorPos pos=:{col, row} SNil = pos newCursorPos {col, row} (SCons string SNil) = {col = col + size string, row = row } newCursorPos {col, row} strings = { col = size (slLast strings) , row = row + slLength strings - 1 } */ // ...Wrap Batch startup force_update proj_path initialState world # ((proj,ok,err),world) = accFiles (ReadProjectFile proj_path startup) world | not ok || err <> "" = wAbort ("--batch-build failed while opening project: "+++.err+++."\n") world = startIO NDI initialState (pinit force_update proj proj_path) [ProcessClose closeProcess] world pinit force_update proj proj_path ps # ps = setInteract False ps # ps = setProject proj ps # ps = setProjectFilePath proj_path ps # ps = selectProjectTarget getTargets ps # ps = ew_safe_close ps // close error window # ps = tw_safe_close ps // close types window # ps = BringProjectUptoDate force_update cleanup ps = ps where cleanup exepath linked ok ps = abortLog (not ok) "" ps