hpage-0.4.1: src/HPage/GUI/FreeTextWindow.hs
{-# LANGUAGE GeneralizedNewtypeDeriving,
MultiParamTypeClasses,
FlexibleInstances,
FlexibleContexts,
FunctionalDependencies,
UndecidableInstances #-}
module HPage.GUI.FreeTextWindow ( gui ) where
import Control.Concurrent.Process
import Control.Concurrent.MVar
import System.FilePath
import System.Directory
import System.IO.Error hiding (try)
import Data.List
import Data.Bits
import Data.Char (toLower)
import Data.Version
import Distribution.Package
import Control.Monad.Error
import Control.Monad.Loops
import Graphics.UI.WX
import Graphics.UI.WXCore
import Graphics.UI.WXCore.Types
import Graphics.UI.WXCore.Dialogs
import Graphics.UI.WXCore.Events
import Graphics.UI.WXCore.WxcClasses
import qualified HPage.Control as HP
import qualified HPage.Server as HPS
import HPage.GUI.Dialogs
import HPage.GUI.IDs
import HPage.Utils.Log
import Paths_hpage -- cabal locations of data files
imageFile :: FilePath -> IO FilePath
imageFile fp = do
path <- getDataFileName $ "res/images/" ++ fp
real <- doesFileExist path
if real then return path
else do
errorIO ("file not found", path)
fail (path ++ " does not exist")
helpFile :: IO FilePath
helpFile = getDataFileName "res/help/helpPage.hs"
data GUIResultRow = GUIRRow { grrButton :: Button (),
grrText :: TextCtrl ()}
data GUIResults = GUIRes { resValue :: GUIResultRow,
resType :: GUIResultRow,
resKind :: GUIResultRow }
data GUIContext = GUICtx { guiWin :: Frame (),
guiPages :: SingleListBox (),
guiPkgModules :: SingleListBox (),
guiLoadedModules :: ListCtrl (),
guiCode :: TextCtrl (),
guiResults :: GUIResults,
guiStatus :: StatusField,
guiTimer :: Var (TimerEx ()),
guiSearch :: FindReplaceData ()}
gui :: IO ()
gui =
do
-- Server context
model <- HPS.start
win <- frame [text := "λPage"]
imageFile "icon/hpage.tif" >>= topLevelWindowSetIconFromFile win
set win [on closing := HPS.stop model >> propagateEvent]
-- Containers
ntbkL <- notebook win []
pnlPs <- panel ntbkL []
pnlPMs <- panel ntbkL []
pnlLMs <- panel ntbkL []
-- Text page...
-- txtCode <- styledTextCtrl win []
txtCode <- textCtrl win [font := fontFixed, text := ""]
-- Document Selector
lstPages <- singleListBox pnlPs [style := wxLB_NEEDED_SB, outerSize := sz 400 600]
-- Modules Lists
imageFiles <- mapM imageFile ["imported.png", "interpreted.png", "compiled.png"]
imagePaths <- mapM getAbsoluteFilePath imageFiles
images <- imageListFromFiles (sz 16 16) imagePaths
lstLoadedModules <- listCtrlEx pnlLMs (wxLC_NO_HEADER + wxLC_SINGLE_SEL)
[columns := [("Module", AlignLeft, 200)]]
listCtrlSetImageList lstLoadedModules images wxIMAGE_LIST_SMALL
lstPkgModules <- singleListBox pnlPMs [style := wxLB_NEEDED_SB]
-- Results list
txtValue <- textEntry win [style := wxTE_READONLY]
txtType <- textEntry win [style := wxTE_READONLY]
txtKind <- textEntry win [style := wxTE_READONLY]
-- Status bar...
status <- statusField [text := "hello... this is λPage! type in your instructions :)"]
refreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"]
varTimer <- varCreate refreshTimer
set win [statusBar := [status]]
btnGetValue <- button win [text := "Value"]
btnGetType <- button win [text := "Type"]
btnGetKind <- button win [text := "Kind"]
search <- findReplaceDataCreate wxFR_DOWN
let grrValue = GUIRRow btnGetValue txtValue
let grrType = GUIRRow btnGetType txtType
let grrKind = GUIRRow btnGetKind txtKind
let guiRes = GUIRes grrValue grrType grrKind
let guiCtx = GUICtx win lstPages lstPkgModules lstLoadedModules txtCode guiRes status varTimer search
let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx
set btnGetValue [on command := onCmd "getValue" getValue]
set btnGetType [on command := onCmd "getType" getType]
set btnGetKind [on command := onCmd "getKind" getKind]
-- Events
set lstPages [on select := onCmd "pageChange" pageChange]
set txtCode [on keyboard := \_ -> onCmd "restartTimer" restartTimer >> propagateEvent,
on mouse := \e -> case e of
MouseLeftUp _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent
MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent
MouseRightDown _ _ -> onCmd "textContextMenu" textContextMenu
_ -> propagateEvent]
set lstLoadedModules [on listEvent := \e -> case e of
ListItemSelected idx -> onCmd "browseModule" (browseModule idx)
_ -> propagateEvent]
set lstPkgModules [on mouse := \e -> case e of
MouseRightUp _ _ -> onCmd "pkgModuleContextMenu" pkgModuleContextMenu >> propagateEvent
MouseLeftDClick _ _ -> onCmd "loadModulesByNameFast" loadModulesByNameFast
_ -> propagateEvent]
-- Menu bar...
-- menuBar win []
mnuPage <- menuPane [text := "Page"]
menuAppend mnuPage wxId_NEW "&New\tCtrl-n" "New Page" False
menuAppend mnuPage wxId_CLOSE "&Close\tCtrl-w" "Close Page" False
menuAppend mnuPage wxId_CLOSE_ALL "&Close All\tCtrl-Shift-w" "Close All Pages" False
menuAppendSeparator mnuPage
menuAppend mnuPage wxId_OPEN "&Open...\tCtrl-o" "Open Page" False
menuAppend mnuPage wxId_SAVE "&Save\tCtrl-s" "Save Page" False
menuAppend mnuPage wxId_SAVEAS "&Save as...\tCtrl-Shift-s" "Save Page as" False
menuAppendSeparator mnuPage
menuQuit mnuPage [on command := close win]
mnuEdit <- menuPane [text := "Edit"]
menuAppend mnuEdit wxId_UNDO "&Undo\tCtrl-z" "Undo" False
menuAppend mnuEdit wxId_REDO "&Redo\tCtrl-Shift-z" "Redo" False
menuAppendSeparator mnuEdit
menuAppend mnuEdit wxId_CUT "C&ut\tCtrl-x" "Cut" False
menuAppend mnuEdit wxId_COPY "&Copy\tCtrl-c" "Copy" False
menuAppend mnuEdit wxId_PASTE "&Paste\tCtrl-v" "Paste" False
menuAppendSeparator mnuEdit
menuAppend mnuEdit wxId_FIND "&Find...\tCtrl-f" "Find" False
menuAppend mnuEdit wxId_FORWARD "Find &Next\tCtrl-g" "Find Next" False
menuAppend mnuEdit wxId_BACKWARD "Find &Previous\tCtrl-Shift-g" "Find Previous" False
menuAppend mnuEdit wxId_REPLACE "&Replace...\tCtrl-Shift-r" "Replace" False
menuAppendSeparator mnuEdit
menuAppend mnuEdit wxId_PREFERENCES "&Preferences...\tCtrl-," "Preferences" False
mnuHask <- menuPane [text := "Haskell"]
menuAppend mnuHask wxId_HASK_LOAD_PKG "Load &package...\tCtrl-Shift-l" "Load Cabal Package" False
menuAppendSeparator mnuHask
menuAppend mnuHask wxId_HASK_LOAD "&Load modules...\tCtrl-l" "Load Modules" False
menuAppend mnuHask wxId_HASK_LOADNAME "Load modules by &name...\tCtrl-Shift-l" "Load Modules by Name" False
menuAppend mnuHask wxId_HASK_ADD "Import modules...\tCtrl-Shift-i" "Import Packaged Modules by Name" False
menuAppend mnuHask wxId_HASK_RELOAD "&Reload\tCtrl-r" "Reload Modules" False
menuAppendSeparator mnuHask
menuAppend mnuHask wxId_HASK_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False
menuAppend mnuHask wxId_HASK_TYPE "&Type\tCtrl-t" "Get the Type of the Current Expression" False
menuAppend mnuHask wxId_HASK_KIND "&Kind\tCtrl-k" "Get the Kind of the Current Expression" False
mnuHelp <- menuHelp []
menuAppend mnuHelp wxId_HELP "&Help page\tCtrl-h" "Open the Help Page" False
menuAbout mnuHelp [on command := infoDialog win "About λPage" "Author: Fernando Brujo Benavides"]
set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]]
evtHandlerOnMenuCommand win wxId_NEW $ onCmd "runHP' addPage" $ runHP' HP.addPage
evtHandlerOnMenuCommand win wxId_CLOSE $ onCmd "runHP' closePage" $ runHP' HP.closePage
evtHandlerOnMenuCommand win wxId_CLOSE_ALL $ onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages
evtHandlerOnMenuCommand win wxId_OPEN $ onCmd "openPage" openPage
evtHandlerOnMenuCommand win wxId_SAVE $ onCmd "savePage" savePage
evtHandlerOnMenuCommand win wxId_SAVEAS $ onCmd "savePageAs" savePageAs
evtHandlerOnMenuCommand win wxId_UNDO $ onCmd "runHP' undo" $ runHP' HP.undo
evtHandlerOnMenuCommand win wxId_REDO $ onCmd "runHP' redo" $ runHP' HP.redo
evtHandlerOnMenuCommand win wxId_CUT $ onCmd "cut" cut
evtHandlerOnMenuCommand win wxId_COPY $ onCmd "copy" copy
evtHandlerOnMenuCommand win wxId_PASTE $ onCmd "paste" paste
evtHandlerOnMenuCommand win wxId_FIND $ onCmd "justFind" justFind
evtHandlerOnMenuCommand win wxId_FORWARD $ onCmd "findNext" justFindNext
evtHandlerOnMenuCommand win wxId_BACKWARD $ onCmd "findPrev" justFindPrev
evtHandlerOnMenuCommand win wxId_REPLACE $ onCmd "findReplace" findReplace
evtHandlerOnMenuCommand win wxId_HASK_LOAD_PKG $ onCmd "loadPackage" loadPackage
evtHandlerOnMenuCommand win wxId_HASK_LOAD $ onCmd "loadModules" loadModules
evtHandlerOnMenuCommand win wxId_HASK_ADD $ onCmd "importModules" importModules
evtHandlerOnMenuCommand win wxId_HASK_LOADNAME $ onCmd "loadModulesByName" loadModulesByName
evtHandlerOnMenuCommand win wxId_HASK_LOAD_FAST $ onCmd "loadModulesByNameFast" loadModulesByNameFast
evtHandlerOnMenuCommand win wxId_HASK_RELOAD $ onCmd "reloadModules" reloadModules
evtHandlerOnMenuCommand win wxId_PREFERENCES $ onCmd "preferences" configure
evtHandlerOnMenuCommand win wxId_HASK_VALUE $ onCmd "getValue" getValue
evtHandlerOnMenuCommand win wxId_HASK_TYPE $ onCmd "getType" getType
evtHandlerOnMenuCommand win wxId_HASK_KIND $ onCmd "getKind" getKind
evtHandlerOnMenuCommand win wxId_HELP $ onCmd "help" openHelpPage
-- Tool bar...
tbMain <- toolBarEx win True True []
mitLoadPkg <- menuFindItem mnuHask wxId_HASK_LOAD_PKG
mitNew <- menuFindItem mnuPage wxId_NEW
mitOpen <- menuFindItem mnuPage wxId_OPEN
mitSave <- menuFindItem mnuPage wxId_SAVE
mitCut <- menuFindItem mnuEdit wxId_CUT
mitCopy <- menuFindItem mnuEdit wxId_COPY
mitPaste <- menuFindItem mnuEdit wxId_PASTE
mitReload <- menuFindItem mnuHask wxId_HASK_RELOAD
loadPath <- imageFile "load.png"
newPath <- imageFile "new.png"
openPath <- imageFile "open.png"
savePath <- imageFile "save.png"
cutPath <- imageFile "cut.png"
copyPath <- imageFile "copy.png"
pastePath <- imageFile "paste.png"
reloadPath <- imageFile "reload.png"
toolMenu tbMain mitLoadPkg "Load Package" loadPath [tooltip := "Load Cabal Package"]
toolBarAddSeparator tbMain
toolMenu tbMain mitNew "New" newPath [tooltip := "New Page"]
toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open Page"]
toolMenu tbMain mitSave "Save" savePath [tooltip := "Save Page"]
toolBarAddSeparator tbMain
toolMenu tbMain mitCut "Cut" cutPath [tooltip := "Cut"]
toolMenu tbMain mitCopy "Copy" copyPath [tooltip := "Copy"]
toolMenu tbMain mitPaste "Paste" pastePath [tooltip := "Paste"]
toolBarAddSeparator tbMain
toolMenu tbMain mitReload "Reload" reloadPath [tooltip := "Reload Modules"]
toolBarSetToolBitmapSize tbMain $ sz 32 32
-- Layout settings
let txtCodeL = fill $ widget txtCode
pagesTabL = tab "Pages" $ container pnlPs $ fill $ margin 5 $ widget lstPages
pkgModsTabL = tab "Package" $ container pnlPMs $ fill $ margin 5 $ widget lstPkgModules
lddModsTabL = tab "Modules" $ container pnlLMs $ fill $ margin 5 $ widget lstLoadedModules
valueRowL = [widget btnGetValue, hfill $ widget txtValue]
typeRowL = [widget btnGetType, hfill $ widget txtType]
kindRowL = [widget btnGetKind, hfill $ widget txtKind]
resultsGridL= hfill $ boxed "Expression" $ grid 5 0 [valueRowL, typeRowL, kindRowL]
leftL = tabs ntbkL [lddModsTabL, pkgModsTabL, pagesTabL]
rightL = minsize (sz 485 100) $ column 5 [txtCodeL, resultsGridL]
set win [layout := fill $ row 10 [leftL, rightL],
clientSize := sz 800 600]
-- ...and RUN!
refreshPage model guiCtx
onCmd "start" openHelpPage
focusOn txtCode
-- EVENT HANDLERS --------------------------------------------------------------
refreshPage, savePageAs, savePage, openPage,
pageChange, copy, cut, paste,
justFind, justFindNext, justFindPrev, findReplace,
textContextMenu, pkgModuleContextMenu,
restartTimer, killTimer,
getValue, getType, getKind,
loadPackage, loadModules, importModules, loadModulesByName, loadModulesByNameFast, reloadModules,
configure, openHelpPage :: HPS.ServerHandle -> GUIContext -> IO ()
browseModule :: Int -> HPS.ServerHandle -> GUIContext -> IO ()
browseModule i model guiCtx@GUICtx{guiWin = win, guiLoadedModules = lstLoadedModules, guiCode = txtCode} =
do
contextMenu <- menuPane []
mn <- listCtrlGetItemText lstLoadedModules i
hpsRes <- tryIn model $ HP.getModuleExports mn
case hpsRes of
Left err ->
propagateEvent >> warningDialog win "Error" err
Right mes ->
do
flip mapM_ mes $ createMenuItem contextMenu
propagateEvent
pointWithinWindow <- windowGetMousePosition win
menuPopup contextMenu pointWithinWindow win
objectDelete contextMenu
where createMenuItem m fn@(HP.MEFun _ _) =
do
item <- menuItemCreate
menuItemSetCheckable item False
menuItemSetText item $ show fn
menuItemSetId item wxId_HASK_MENUELEM
menuAppendItem m item
createMenuItem m HP.MEClass{HP.clsName = cn, HP.clsFuns = []} =
do
item <- menuItemCreate
menuItemSetCheckable item False
menuItemSetText item $ "class " ++ cn
menuItemSetId item wxId_HASK_MENUELEM
menuAppendItem m item
createMenuItem m HP.MEClass{HP.clsName = cn, HP.clsFuns = cfs} =
do
subMenu <- menuPane []
flip mapM_ cfs $ createMenuItem subMenu
menuAppendSub m wxId_HASK_MENUELEM ("class " ++ cn) subMenu ""
createMenuItem m HP.MEData{HP.datName = dn, HP.datCtors = []} =
do
item <- menuItemCreate
menuItemSetCheckable item False
menuItemSetText item $ "data " ++ dn
menuItemSetId item wxId_HASK_MENUELEM
menuAppendItem m item
createMenuItem m HP.MEData{HP.datName = dn, HP.datCtors = dcs} =
do
subMenu <- menuPane []
flip mapM_ dcs $ createMenuItem subMenu
menuAppendSub m wxId_HASK_MENUELEM ("data " ++ dn) subMenu ""
textContextMenu model guiCtx@GUICtx{guiWin = win, guiCode = txtCode} =
do
contextMenu <- menuPane []
sel <- textCtrlGetStringSelection txtCode
case sel of
"" ->
return ()
_ ->
do
menuAppend contextMenu wxId_CUT "C&ut\tCtrl-x" "Cut" False
menuAppend contextMenu wxId_COPY "&Copy\tCtrl-c" "Copy" False
menuAppend contextMenu wxId_PASTE "&Paste\tCtrl-v" "Paste" False
menuAppendSeparator contextMenu
menuAppend contextMenu wxId_HASK_VALUE "&Value\tCtrl-e" "Get the Value of the Current Expression" False
menuAppend contextMenu wxId_HASK_TYPE "&Type\tCtrl-t" "Get the Type of the Current Expression" False
menuAppend contextMenu wxId_HASK_KIND "&Kind\tCtrl-k" "Get the Kind of the Current Expression" False
propagateEvent
pointWithinWindow <- windowGetMousePosition win
menuPopup contextMenu pointWithinWindow win
objectDelete contextMenu
pkgModuleContextMenu model guiCtx@GUICtx{guiWin = win, guiPkgModules = lstPkgModules} =
do
contextMenu <- menuPane []
i <- get lstPkgModules selection
case i of
(-1) -> return ()
i ->
do
mnText <- listBoxGetString lstPkgModules i
menuAppend contextMenu wxId_HASK_LOAD_FAST "&Load" "Load Module" False
propagateEvent
pointWithinWindow <- windowGetMousePosition win
menuPopup contextMenu pointWithinWindow win
objectDelete contextMenu
getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} =
runTxtHP HP.valueOf' model guiCtx grrValue
getType model guiCtx@GUICtx{guiResults = GUIRes{resType = grrType}} =
runTxtHP HP.typeOf' model guiCtx grrType
getKind model guiCtx@GUICtx{guiResults = GUIRes{resKind = grrKind}} =
runTxtHP HP.kindOf' model guiCtx grrKind
pageChange model guiCtx@GUICtx{guiPages = lstPages} =
do
i <- get lstPages selection
case i of
(-1) -> return ()
_ -> runHP' (HP.setPageIndex i) model guiCtx
openPage model guiCtx@GUICtx{guiWin = win,
guiStatus = status} =
do
fileNames <- filesOpenDialog win True True "Open file..." [("Haskells",["*.hs"]),
("Any file",["*.*"])] "" ""
case fileNames of
[] ->
return ()
fs ->
do
set status [text := "opening..."]
flip mapM_ fs $ \f -> runHP' (HP.openPage f) model guiCtx
savePageAs model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
do
fileName <- fileSaveDialog win True True "Save file..." [("Haskells",["*.hs"]),
("Any file",["*.*"])] "" ""
case fileName of
Nothing ->
return ()
Just f ->
do
set status [text := "saving..."]
runHP' (HP.savePageAs f) model guiCtx
savePage model guiCtx@GUICtx{guiWin = win} =
do
maybePath <- tryIn' model HP.getPagePath
case maybePath of
Left err ->
warningDialog win "Error" err
Right Nothing ->
savePageAs model guiCtx
Right _ ->
do
set (guiStatus guiCtx) [text := "saving..."]
runHP' HP.savePage model guiCtx
copy _model GUICtx{guiCode = txtCode} = textCtrlCopy txtCode
cut model guiCtx@GUICtx{guiCode = txtCode} = textCtrlCut txtCode >> refreshPage model guiCtx
paste model guiCtx@GUICtx{guiCode = txtCode} = textCtrlPaste txtCode >> refreshPage model guiCtx
justFind model guiCtx = openFindDialog model guiCtx "Find..." dialogDefaultStyle
justFindNext model guiCtx@GUICtx{guiSearch = search} =
do
curFlags <- findReplaceDataGetFlags search
findReplaceDataSetFlags search $ curFlags .|. wxFR_DOWN
findNextButton model guiCtx
justFindPrev model guiCtx@GUICtx{guiSearch = search} =
do
curFlags <- findReplaceDataGetFlags search
findReplaceDataSetFlags search $ curFlags .&. complement wxFR_DOWN
findNextButton model guiCtx
findReplace model guiCtx = openFindDialog model guiCtx "Find and Replace..." $ dialogDefaultStyle .|. wxFR_REPLACEDIALOG
reloadModules = runHP HP.reloadModules
loadPackage model guiCtx@GUICtx{guiWin = win} =
do
distExists <- doesDirectoryExist "dist"
let startDir = if distExists then "dist" else ""
res <- fileOpenDialog win True True "Select the setup-config file for your project..."
[("setup-config",["setup-config"])] startDir "setup-config"
case res of
Nothing ->
return ()
Just setupConfig ->
do
loadres <- tryIn model (HP.loadPackage setupConfig)
case loadres of
Left err ->
warningDialog win "Error" err
Right pkg ->
do
absPath <- canonicalizePath setupConfig
let dir = joinPath . reverse . drop 2 . reverse $ splitDirectories absPath
setCurrentDirectory dir
frameSetTitle win $ "λPage - " ++ prettyShow pkg
refreshPage model guiCtx
where prettyShow PackageIdentifier{pkgName = PackageName pkgname,
pkgVersion = pkgvsn} = pkgname ++ "-" ++ showVersion pkgvsn
loadModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
do
fileNames <- filesOpenDialog win True True "Load Module..." [("Haskell Modules",["*.hs"])] "" ""
case fileNames of
[] ->
return ()
fs ->
do
set status [text := "loading..."]
runHP (HP.loadModules fs) model guiCtx
loadModulesByName model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
do
moduleNames <- textDialog win "Enter the module names, separated by spaces" "Load Modules..." ""
case moduleNames of
"" ->
return ()
mns ->
do
set status [text := "loading..."]
runHP (HP.loadModules $ words mns) model guiCtx
loadModulesByNameFast model guiCtx@GUICtx{guiWin = win, guiPkgModules = lstPkgModules, guiStatus = status} =
do
i <- get lstPkgModules selection
case i of
(-1) -> return ()
i ->
do
mnText <- listBoxGetString lstPkgModules i
let mns = [mnText]
set status [text := "loading..."]
runHP (HP.loadModules mns) model guiCtx
importModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
do
moduleNames <- textDialog win "Enter the module names, separated by spaces" "Import Packaged Modules..." ""
case moduleNames of
"" ->
return ()
mns ->
do
set status [text := "loading..."]
runHP (HP.importModules $ words mns) model guiCtx
configure model guiCtx@GUICtx{guiWin = win, guiStatus = status} =
do
hpsRes <- tryIn model $ do
les <- HP.getLanguageExtensions
sds <- HP.getSourceDirs
gos <- HP.getGhcOpts
case les of
Left e -> return $ Left e
Right l -> return $ Right (l, sds, gos)
case hpsRes of
Left err ->
warningDialog win "Error" err
Right (les, sds, gos) ->
do
res <- preferencesDialog win "Preferences" $ Prefs les sds gos
case res of
Nothing ->
return ()
Just newps ->
do
set status [text := "setting..."]
runHP (do
HP.setLanguageExtensions $ languageExtensions newps
HP.setSourceDirs $ sourceDirs newps
case ghcOptions newps of
"" -> return $ Right ()
newopts -> HP.setGhcOpts newopts
) model guiCtx
openHelpPage model guiCtx@GUICtx{guiCode = txtCode} =
do
f <- helpFile
txt <- readFile f
set txtCode [text := txt]
-- Refresh the current expression box
refreshExpr model guiCtx True
refreshPage model guiCtx@GUICtx{guiWin = win,
guiPages = lstPages,
guiPkgModules = lstPkgModules,
guiLoadedModules = lstLoadedModules,
guiCode = txtCode,
guiStatus = status} =
do
res <- tryIn' model $ do
pc <- HP.getPageCount
pages <- mapM HP.getPageNthDesc [0..pc-1]
ind <- HP.getPageIndex
txt <- HP.getPageText
lmsRes <- HP.getLoadedModules
ims <- HP.getImportedModules
pms <- HP.getPackageModules
let lms = case lmsRes of
Left _ -> []
Right x -> x
return (pms, ims, lms, pages, ind, txt)
case res of
Left err ->
warningDialog win "Error" err
Right (pms, ims, ms, ps, i, t) ->
do
-- Refresh the pages list
itemsDelete lstPages
(flip mapM) ps $ \pd ->
let prefix = if HP.pIsModified pd
then "*"
else ""
name = case HP.pPath pd of
Nothing -> "new page"
Just fn -> takeFileName $ dropExtension fn
in itemAppend lstPages $ prefix ++ name
set lstPages [selection := i]
-- Refresh the modules lists
--NOTE: we know 0 == "imported" / 1 == "interpreted" / 2 == "compiled" images
--TODO: move that to some kind of constants or so
let ims' = map (\m -> (0, m)) ims
ms' = map (\m -> (if HP.modInterpreted m then 1 else 2, HP.modName m)) ms
allms = zip [0..] (ims' ++ ms')
itemsDelete lstLoadedModules
(flip mapM) allms $ \(idx, (img, m)) ->
listCtrlInsertItemWithLabel lstLoadedModules idx m img >>
set lstLoadedModules [item idx := [m]]
itemsDelete lstPkgModules
(flip mapM) pms $ \pm -> itemAppend lstPkgModules (if any (\xm -> HP.modName xm == pm) ms then ('*':pm) else pm)
-- Refresh the current text
set txtCode [text := t]
-- Clean the status bar
set status [text := ""]
-- Refresh the current expression box
refreshExpr model guiCtx True
runHP' :: HP.HPage () -> HPS.ServerHandle -> GUIContext -> IO ()
runHP' a = runHP $ a >>= return . Right
runHP :: HP.HPage (Either HP.InterpreterError ()) -> HPS.ServerHandle -> GUIContext -> IO ()
runHP hpacc model guiCtx@GUICtx{guiWin = win} =
do
res <- tryIn model hpacc
case res of
Left err ->
warningDialog win "Error" err
Right () ->
refreshPage model guiCtx
runTxtHP, runTxtHPPointer :: HP.HPage (MVar (Either HP.InterpreterError String)) ->
HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO ()
runTxtHPSelection :: String -> HP.HPage (MVar (Either HP.InterpreterError String)) ->
HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO ()
runTxtHP hpacc model guiCtx@GUICtx{guiCode = txtCode} guiRow =
do
sel <- textCtrlGetStringSelection txtCode
let runner = case sel of
"" -> runTxtHPPointer
sl -> runTxtHPSelection sl
runner hpacc model guiCtx guiRow
runTxtHPSelection s hpacc model guiCtx@GUICtx{guiWin = win,
guiStatus = status}
GUIRRow{grrButton = btn,
grrText = txtBox} =
do
refreshExpr model guiCtx False
debugIO ("evaluating selection", s)
piRes <- tryIn' model HP.getPageIndex
let cpi = case piRes of
Left err -> 0
Right cp -> cp
newacc = do
HP.addPage
HP.setPageText s $ length s
hpacc
res <- tryIn' model newacc
tryIn' model $ HP.closePage >> HP.setPageIndex cpi
case res of
Left err -> warningDialog win "Error" err
Right var -> do
cancelled <- varCreate False
prevOnCmd <- get btn $ on command
prevText <- get btn text
let prevAttrs = [text := prevText,
on command := prevOnCmd]
revert = do
varSet cancelled True
tryIn' model HP.cancel
set txtBox [enabled := True]
set btn prevAttrs
set status [text := "cancelled"]
set btn [text := "Cancel", on command := revert]
set txtBox [enabled := False]
set status [text := "processing..."]
spawn . liftIO $ do
val <- readMVar var
wasCancelled <- varGet cancelled
if wasCancelled
then
return ()
else
do
set status [text := "ready"]
case val of
Left err -> warningDialog win "Error" $ HP.prettyPrintError err
Right txt -> set txtBox [text := txt]
set txtBox [enabled := True]
set btn prevAttrs
return ()
runTxtHPPointer hpacc model guiCtx@GUICtx{guiWin = win,
guiStatus = status}
GUIRRow{grrButton = btn,
grrText = txtBox} =
do
refreshExpr model guiCtx False
res <- tryIn' model hpacc
case res of
Left err -> warningDialog win "Error" err
Right var -> do
cancelled <- varCreate False
prevOnCmd <- get btn $ on command
prevText <- get btn text
let prevAttrs = [text := prevText,
on command := prevOnCmd]
revert = do
varSet cancelled True
tryIn' model HP.cancel
set txtBox [enabled := True]
set btn prevAttrs
set status [text := "cancelled"]
set btn [text := "Cancel", on command := revert]
set txtBox [enabled := False]
set status [text := "processing..."]
spawn . liftIO $ do
val <- readMVar var
wasCancelled <- varGet cancelled
if wasCancelled
then
return ()
else
do
set status [text := "ready"]
case val of
Left err -> warningDialog win "Error" $ HP.prettyPrintError err
Right txt -> set txtBox [text := txt]
set txtBox [enabled := True]
set btn prevAttrs
return ()
refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO ()
refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue,
resType = grrType,
resKind = grrKind},
guiCode = txtCode,
guiWin = win} forceClear =
do
txt <- get txtCode text
ip <- textCtrlGetInsertionPoint txtCode
res <- tryIn' model $ HP.setPageText txt ip
case res of
Left err ->
warningDialog win "Error" err
Right changed ->
if changed || forceClear
then mapM_ (flip set [text := ""] . grrText) [grrValue, grrType, grrKind]
else debugIO "dummy refreshExpr"
killTimer model guiCtx
-- TIMER HANDLERS --------------------------------------------------------------
restartTimer model guiCtx@GUICtx{guiWin = win, guiTimer = varTimer} =
do
newRefreshTimer <- timer win [interval := 1000,
on command := refreshExpr model guiCtx False]
refreshTimer <- varSwap varTimer newRefreshTimer
timerOnCommand refreshTimer $ return ()
killTimer _model GUICtx{guiWin = win, guiTimer = varTimer} =
do
-- kill the timer till there's new notices
newRefreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"]
refreshTimer <- varSwap varTimer newRefreshTimer
timerOnCommand refreshTimer $ return ()
-- INTERNAL UTILS --------------------------------------------------------------
type ErrorString = String
tryIn' :: HPS.ServerHandle -> HP.HPage x -> IO (Either ErrorString x)
tryIn' model hpacc = tryIn model $ hpacc >>= return . Right
tryIn :: HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError x) -> IO (Either ErrorString x)
tryIn model hpacc =
do
res <- HPS.runIn model $ catchError (hpacc >>= return . Right)
(\ioerr -> return $ Left ioerr)
case res of
Left err -> do
errorIO err
return . Left $ ioeGetErrorString err
Right (Left err) -> return . Left $ HP.prettyPrintError err
Right (Right val) -> return . Right $ val
-- FIND/REPLACE UTILS ----------------------------------------------------------
data FRFlags = FRFlags {frfGoingDown :: Bool,
frfMatchCase :: Bool,
frfWholeWord :: Bool,
frfWrapSearch :: Bool}
deriving (Eq, Show)
buildFRFlags :: Bool -> Int -> IO FRFlags
buildFRFlags w x = return FRFlags {frfGoingDown = (x .&. wxFR_DOWN) /= 0,
frfMatchCase = (x .&. wxFR_MATCHCASE) /= 0,
frfWholeWord = (x .&. wxFR_WHOLEWORD) /= 0,
frfWrapSearch = w}
openFindDialog :: HPS.ServerHandle -> GUIContext -> String -> Int -> IO ()
openFindDialog model guiCtx@GUICtx{guiWin = win,
guiSearch = search} title dlgStyle =
do
frdialog <- findReplaceDialogCreate win search title $ dlgStyle + wxFR_NOWHOLEWORD
let winSet k f = let hnd _ = f model guiCtx >> propagateEvent
in windowOnEvent frdialog [k] hnd hnd
winSet wxEVT_COMMAND_FIND findNextButton
winSet wxEVT_COMMAND_FIND_NEXT findNextButton
winSet wxEVT_COMMAND_FIND_REPLACE findReplaceButton
winSet wxEVT_COMMAND_FIND_REPLACE_ALL findReplaceAllButton
set frdialog [visible := True]
findNextButton, findReplaceButton, findReplaceAllButton :: HPS.ServerHandle -> GUIContext -> IO ()
findNextButton model guiCtx@GUICtx{guiCode = txtCode,
guiWin = win,
guiSearch = search} =
do
s <- findReplaceDataGetFindString search
fs <- findReplaceDataGetFlags search >>= buildFRFlags True
mip <- findMatch s fs txtCode
debugIO ("find/next", s, fs, mip)
case mip of
Nothing ->
infoDialog win "Find Results" $ s ++ " not found."
Just ip ->
do
textCtrlSetSelection txtCode (length s + ip) ip
refreshExpr model guiCtx False
findReplaceButton model guiCtx@GUICtx{guiCode = txtCode,
guiWin = win,
guiSearch = search} =
do
s <- findReplaceDataGetFindString search
r <- findReplaceDataGetReplaceString search
fs <- findReplaceDataGetFlags search >>= buildFRFlags True
mip <- findMatch s fs txtCode
debugIO ("replace", s, r, fs, mip)
case mip of
Nothing ->
infoDialog win "Find Results" $ s ++ " not found."
Just ip ->
do
textCtrlReplace txtCode ip (length s + ip) r
textCtrlSetSelection txtCode (length r + ip) ip
refreshExpr model guiCtx False
findReplaceAllButton _model GUICtx{guiCode = txtCode,
guiSearch = search} =
do
s <- findReplaceDataGetFindString search
r <- findReplaceDataGetReplaceString search
fs <- findReplaceDataGetFlags search >>= buildFRFlags False
debugIO ("all", s, r, fs)
textCtrlSetInsertionPoint txtCode 0
unfoldM_ $ do
mip <- findMatch s fs txtCode
case mip of
Nothing ->
return mip
Just ip ->
do
textCtrlReplace txtCode ip (length s + ip) r
textCtrlSetInsertionPoint txtCode $ length r + ip
return mip
findMatch :: String -> FRFlags -> TextCtrl () -> IO (Maybe Int)
findMatch query flags txtCode =
do
txt <- get txtCode text
ip <- textCtrlGetInsertionPoint txtCode
let (substring, string) = if frfMatchCase flags
then (query, txt)
else (map toLower query, map toLower txt)
funct = if frfGoingDown flags
then nextMatch (ip + 1)
else prevMatch ip
(mip, wrapped) = funct substring string
return $ if (not $ frfWrapSearch flags) && wrapped
then Nothing
else mip
prevMatch, nextMatch :: Int -> String -> String -> (Maybe Int, Bool)
prevMatch _ [] _ = (Nothing, True) -- When looking for nothing, that's what you get
prevMatch from substring string | length string < from || from <= 0 = prevMatch (length string) substring string
| otherwise =
case nextMatch (fromBack from) (reverse substring) (reverse string) of
(Nothing, wrapped) -> (Nothing, wrapped)
(Just ri, wrapped) -> (Just $ fromBack (ri + length substring), wrapped)
where fromBack x = length string - x
nextMatch _ [] _ = (Nothing, True) -- When looking for nothing, that's what you get
nextMatch from substring string | length substring > length string = (Nothing, True)
| length string <= from = nextMatch 0 substring string
| otherwise =
let after = drop from string
before = take (from + length substring) string
aIndex = indexOf substring after
bIndex = indexOf substring before
in case aIndex of
Just ai ->
(Just $ from + ai, False)
Nothing ->
case bIndex of
Nothing -> (Nothing, True)
Just bi -> (Just bi, True)
indexOf :: String -> String -> Maybe Int
indexOf substring string = findIndex (isPrefixOf substring) $ tails string