leksah 0.4.0.1 → 0.4.0.2
raw patch · 6 files changed
+157/−207 lines, 6 files
Files
- data/Default.candy +2/−2
- leksah.cabal +2/−2
- src/Graphics/UI/Frame/Panes.hs +1/−1
- src/Graphics/UI/Frame/ViewFrame.hs +2/−8
- src/IDE/Pane/Modules.hs +35/−36
- src/IDE/Pane/SourceBuffer.hs +115/−158
data/Default.candy view
@@ -10,11 +10,11 @@ "||" 0x2228 --LOGICAL OR "++" 0x2295 --CIRCLED PLUS --"::" 0x2551 Trimming --BAR-"::" 0x2237 Trimming --PROPORTION+--"::" 0x2237 Trimming --PROPORTION ".." 0x2025 --TWO DOT LEADER "^" 0x2191 --UPWARDS ARROW "==" 0x2261 --IDENTICAL TO-" . " 0x2218 --RING OPERATOR+--" . " 0x2218 --RING OPERATOR "\" 0x03bb --GREEK SMALL LETTER LAMBDA --"=<<" 0x291e -- ">>=" 0x21a0
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.4.0.1+version: 0.4.0.2 cabal-version: >=1.4 build-type: Custom license: GPL@@ -68,7 +68,7 @@ IDE.Core.State IDE.Core.Types ghc-prof-options: -prof -auto-all ghc-shared-options: -prof -auto-all-ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns +ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns hugs-options: nhc98-options: jhc-options:
src/Graphics/UI/Frame/Panes.hs view
@@ -80,7 +80,7 @@ getTopWidget :: alpha -> Widget paneId :: alpha -> String makeActive :: alpha -> beta ()- makeActive _ = return ()+-- makeActive _ = return () close :: alpha -> beta () class (Pane alpha delta, Read beta, Show beta, Typeable beta, PaneMonad delta)
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -67,11 +67,7 @@ import Data.Map (Map) import Data.List import Data.Maybe-#if __GLASGOW_HASKELL__ >= 609 import Control.OldException(evaluate,catch)-#else-import Control.Exception(evaluate,catch)-#endif import Prelude hiding(catch) import Data.Unique import Data.Typeable@@ -133,8 +129,6 @@ realPos <- notebookInsertPageMenu nb widget tabLabel menuLabel pos notebookSetCurrentPage nb realPos -- -- | Constructs a unique pane name, which is an index and a string figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String) figureOutPaneName bufs bn ind =@@ -152,7 +146,7 @@ mbPane <- mbPaneFromName pn case mbPane of Just p -> return p- Nothing -> error $"Cant't find pane from unique name " ++ pn+ Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) mbPaneFromName pn = do@@ -185,7 +179,7 @@ mbNb <- getActiveNotebook case mbNb of Nothing -> return ()- Just nb -> liftIO $do+ Just nb -> liftIO $ do b <- notebookGetShowTabs nb notebookSetShowTabs nb (not b)
src/IDE/Pane/Modules.hs view
@@ -943,43 +943,42 @@ addModule treeView store = do sel <- liftIO $ treeViewGetSelection treeView paths <- liftIO $ treeSelectionGetSelectedRows sel- case paths of- [] -> return ()- (treePath:_) -> do- categories <- liftIO $ mapM (treeStoreGetValue store)+ categories <- case paths of+ [] -> return []+ (treePath:_) -> liftIO $ mapM (treeStoreGetValue store) $ map (\n -> take n treePath) [1 .. length treePath]- mbPD <- getPackageDescriptionAndPath- case mbPD of- Nothing -> ideMessage Normal "No package description"- Just (pd,cabalPath) -> let srcPaths = concatMap hsSourceDirs $ allBuildInfo pd- rootPath = dropFileName cabalPath- modPath = foldr (\a b -> a ++ "." ++ b) ""- (map fst categories)- in do- mbResp <- liftIO $ addModuleDialog modPath srcPaths- case mbResp of- Nothing -> return ()- Just (AddModule modPath srcPath isExposed) ->- let splitter = split '.' modPath- (modPaths,[modName])= splitAt (length splitter - 1) splitter- targetPath = foldl' (</>) (rootPath </> srcPath) modPaths- targetFile = targetPath </> (modName ++ ".hs")- in do- liftIO $ createDirectoryIfMissing True targetPath- alreadyExists <- liftIO $ doesFileExist targetFile- if alreadyExists- then ideMessage Normal "File already exists"- else do- template <- liftIO $ getModuleTemplate pd modName- liftIO $ writeFile targetFile template- addModuleToPackageDescr- (forceJust (simpleParse modPath)- ("Modules>>addModule Can't parse module name " ++ modPath))- isExposed- packageConfig- rebuildActiveInfo- trace ("now openening " ++ targetFile) $ return ()- fileOpenThis targetFile+ mbPD <- getPackageDescriptionAndPath+ case mbPD of+ Nothing -> ideMessage Normal "No package description"+ Just (pd,cabalPath) -> let srcPaths = concatMap hsSourceDirs $ allBuildInfo pd+ rootPath = dropFileName cabalPath+ modPath = foldr (\a b -> a ++ "." ++ b) ""+ (map fst categories)+ in do+ mbResp <- liftIO $ addModuleDialog modPath srcPaths+ case mbResp of+ Nothing -> return ()+ Just (AddModule modPath srcPath isExposed) ->+ let splitter = split '.' modPath+ (modPaths,[modName])= splitAt (length splitter - 1) splitter+ targetPath = foldl' (</>) (rootPath </> srcPath) modPaths+ targetFile = targetPath </> (modName ++ ".hs")+ in do+ liftIO $ createDirectoryIfMissing True targetPath+ alreadyExists <- liftIO $ doesFileExist targetFile+ if alreadyExists+ then ideMessage Normal "File already exists"+ else do+ template <- liftIO $ getModuleTemplate pd modName+ liftIO $ writeFile targetFile template+ addModuleToPackageDescr+ (forceJust (simpleParse modPath)+ ("Modules>>addModule Can't parse module name " ++ modPath))+ isExposed+ packageConfig+ rebuildActiveInfo+ trace ("now openening " ++ targetFile) $ return ()+ fileOpenThis targetFile -- |* Yet another stupid little dialog
src/IDE/Pane/SourceBuffer.hs view
@@ -75,8 +75,6 @@ import Data.Maybe import Data.Typeable import System.Time---import GHC.Conc---import Debug.Trace import IDE.Core.State import Control.Event@@ -85,6 +83,7 @@ import qualified System.IO.UTF8 as UTF8 import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..))+import Data.IORef (writeIORef,readIORef,newIORef,IORef(..)) -- -- | A text editor pane description@@ -95,7 +94,7 @@ , addedIndex :: Int , sourceView :: SourceView , scrolledWindow :: ScrolledWindow-, modTime :: Maybe (ClockTime)+, modTime :: IORef (Maybe (ClockTime)) , language :: Maybe String } deriving (Typeable) @@ -111,43 +110,37 @@ paneId b = case fileName b of Just s -> s Nothing -> "?" ++ bufferName b- makeActive buf = do- (PaneC pane) <- paneFromName (paneName buf)- let mbActbuf = cast pane- if isJust mbActbuf- then do- let actbuf = fromJust mbActbuf- ideR <- ask- sbLC <- getStatusbarLC- sbIO <- getStatusbarIO- infos <- readIDE accessibleInfo- let sv = sourceView actbuf- (cids) <- reifyIDE $ \ideR session -> do- gtkBuf <- textViewGetBuffer sv- bringPaneToFront actbuf- writeCursorPositionInStatusbar sv sbLC- writeOverwriteInStatusbar sv sbIO- id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR session- id2 <- sv `afterMoveCursor`- (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC)- id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC- sv `widgetAddEvents` [ButtonReleaseMask]- id5 <- sv `onButtonRelease`- (\ e -> do- writeCursorPositionInStatusbar sv sbLC- when (controlIsPressed e) $ showInfo sv ideR session- return False)- id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO- return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3]- activatePane actbuf cids- liftIO $- idleAdd (do- widgetQueueDraw sv -- Patch for problem on one machine ##- return False) priorityDefaultIdle- modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Just (paneName buf)}))- triggerEvent ideR (Sensitivity [(SensitivityEditor, True)])- checkModTime actbuf- else return ()+ makeActive actbuf = do+ ideR <- ask+ sbLC <- getStatusbarLC+ sbIO <- getStatusbarIO+ infos <- readIDE accessibleInfo+ let sv = sourceView actbuf+ (cids) <- reifyIDE $ \ideR session -> do+ gtkBuf <- textViewGetBuffer sv+ bringPaneToFront actbuf+ writeCursorPositionInStatusbar sv sbLC+ writeOverwriteInStatusbar sv sbIO+ id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR session+ id2 <- sv `afterMoveCursor`+ (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC)+ id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC+ sv `widgetAddEvents` [ButtonReleaseMask]+ id5 <- sv `onButtonRelease`+ (\ e -> do+ writeCursorPositionInStatusbar sv sbLC+ when (controlIsPressed e) $ showInfo sv ideR session+ return False)+ id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO+ return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3]+ activatePane actbuf cids+ liftIO $+ idleAdd (do+ widgetQueueDraw sv -- Patch for problem on one machine ##+ return False) priorityDefaultIdle+ modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Just (paneName actbuf)}))+ triggerEvent ideR (Sensitivity [(SensitivityEditor, True)])+ checkModTime actbuf close pane = do makeActive pane fileClose return ()@@ -368,8 +361,8 @@ containerAdd sw sv scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic scrolledWindowSetShadowType sw ShadowIn-- let buf = IDEBuffer mbfn bn ind sv sw modTime mbLanguage+ modTimeRef <- newIORef modTime+ let buf = IDEBuffer mbfn bn ind sv sw modTimeRef mbLanguage notebookInsertOrdered nb sw rbn Nothing -- events cid <- sv `afterFocusIn`@@ -393,33 +386,27 @@ exists <- liftIO $doesFileExist fn if exists then do- nmt <- liftIO $getModificationTime fn- case modTime buf of+ nmt <- liftIO $ getModificationTime fn+ modTime' <- liftIO $ readIORef (modTime buf)+ case modTime' of Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf) Just mt -> do --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt if nmt /= mt then do- md <- liftIO $messageDialogNew+ md <- liftIO $ messageDialogNew Nothing [] MessageQuestion ButtonsYesNo ("File has changed on disk " ++ name ++ " Revert?")- resp <- liftIO $dialogRun md+ resp <- liftIO $ dialogRun md case resp of ResponseYes -> do revert buf- liftIO $widgetHide md- ResponseNo -> do- let newPanes = Map.adjust (\(PaneC b) ->- let mbActbuf = cast b- in if isJust mbActbuf- then PaneC ((fromJust mbActbuf)- {modTime = (Just nmt)})- else PaneC b)- name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))- liftIO $widgetHide md+ liftIO $ widgetHide md+ ResponseNo -> liftIO $ do+ writeIORef (modTime buf) (Just nmt)+ widgetHide md _ -> do return () else return () else return ()@@ -431,15 +418,9 @@ let name = paneName buf case fileName buf of Nothing -> return ()- Just fn -> do- nmt <- liftIO $getModificationTime fn- let newPanes = Map.adjust (\(PaneC b) ->- let mbActbuf = cast b- in if isJust mbActbuf- then PaneC ((fromJust mbActbuf){modTime = (Just nmt)})- else PaneC b)- name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))+ Just fn -> liftIO $ do+ nmt <- getModificationTime fn+ writeIORef (modTime buf) (Just nmt) fileRevert :: IDEAction fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do@@ -453,27 +434,20 @@ let name = paneName buf case fileName buf of Nothing -> return ()- Just fn -> do- mt <- liftIO $do- buffer' <- textViewGetBuffer (sourceView buf)- let buffer = castToSourceBuffer buffer'- fc <- UTF8.readFile fn- mt <- getModificationTime fn- sourceBufferBeginNotUndoableAction buffer- textBufferSetText buffer fc- if useCandy- then transformToCandy ct (castToTextBuffer buffer)- else return ()- sourceBufferEndNotUndoableAction buffer- textBufferSetModified buffer False- return mt- let newPanes = Map.adjust (\(PaneC b) ->- let mbActbuf = cast b- in if isJust mbActbuf- then PaneC ((fromJust mbActbuf){modTime = (Just mt)})- else (PaneC b))- name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))+ Just fn -> liftIO $do+ buffer' <- textViewGetBuffer (sourceView buf)+ let buffer = castToSourceBuffer buffer'+ fc <- UTF8.readFile fn+ mt <- getModificationTime fn+ sourceBufferBeginNotUndoableAction buffer+ textBufferSetText buffer fc+ if useCandy+ then transformToCandy ct (castToTextBuffer buffer)+ else return ()+ sourceBufferEndNotUndoableAction buffer+ textBufferSetModified buffer False+ return mt+ writeIORef (modTime buf) (Just mt) writeCursorPositionInStatusbar :: SourceView -> Statusbar -> IO() writeCursorPositionInStatusbar sv sb = do@@ -512,7 +486,7 @@ mbBS <- maybeActiveBuf case mbBS of Nothing -> return ()- Just buf -> liftIO $do+ Just buf -> liftIO $ do gtkbuf <- textViewGetBuffer (sourceView buf) modified <- textBufferGetModified gtkbuf mbText <- notebookGetTabLabelText nb (scrolledWindow buf)@@ -555,76 +529,59 @@ paneMap <- readIDE paneMap bs <- getCandyState candy <- readIDE candy- (panePath,connects)- <- guiPropertiesFromName (paneName currentBuffer)- mbnbufsPm <- do- let mbfn = fileName currentBuffer- mbpage <- liftIO $notebookGetNthPage nb i- case mbpage of- Nothing -> throwIDE "fileSave: Page not found"- Just page ->- if isJust mbfn && query == False- then do checkModTime currentBuffer- liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy $fromJust mbfn- setModTime currentBuffer- return Nothing- else reifyIDE $ \ideR session -> do- dialog <- fileChooserDialogNew- (Just $ "Save File")- (Just window)- FileChooserActionSave- [("gtk-cancel" --buttons to display- ,ResponseCancel) --you can use stock buttons- ,("gtk-save"- , ResponseAccept)]- widgetShow dialog- response <- dialogRun dialog- mbFileName <- case response of- ResponseAccept -> fileChooserGetFilename dialog- ResponseCancel -> return Nothing- ResponseDeleteEvent-> return Nothing- _ -> return Nothing- widgetDestroy dialog- case mbFileName of- Nothing -> return Nothing- Just fn -> do- dfe <- doesFileExist fn- resp <- if dfe- then do md <- messageDialogNew (Just window) []- MessageQuestion- ButtonsYesNo- "File already exist. Overwrite?"- resp <- dialogRun md- widgetHide md- return resp- else return ResponseYes- case resp of- ResponseYes -> do- fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy fn- modT <- getModificationTime fn- let bn = takeFileName fn- let bufs1 = Map.delete (paneName currentBuffer) bufs- let (ind,rbn) = figureOutPaneName bufs1 bn 0- cfn <- canonicalizePath fn- let newBuffer = currentBuffer {fileName = Just cfn,- bufferName = bn, addedIndex = ind, modTime = Just modT}- let newBufs = Map.insert rbn (PaneC newBuffer) bufs1- signalDisconnectAll connects- cid1 <- (sourceView currentBuffer) `afterFocusIn`- (\_ -> do reflectIDE (makeActive newBuffer) ideR session- return True)- let paneMap1 = Map.delete rbn paneMap- let newPaneMap = Map.insert rbn- (panePath,[ConnectC cid1]) paneMap- label <- labelNew (Just rbn)- notebookSetTabLabel nb page label- return (Just (newBufs,newPaneMap))- ResponseNo -> return Nothing- _ -> return Nothing- case mbnbufsPm of- Just (nbufs,pm) -> modifyIDE_- (\ide -> return (ide{panes = nbufs, paneMap = pm}))- Nothing -> return ()+ (panePath,connects) <- guiPropertiesFromName (paneName currentBuffer)+ let mbfn = fileName currentBuffer+ mbpage <- liftIO $ notebookGetNthPage nb i+ case mbpage of+ Nothing -> throwIDE "fileSave: Page not found"+ Just page ->+ if isJust mbfn && query == False+ then do checkModTime currentBuffer+ liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy $fromJust mbfn+ setModTime currentBuffer+ return ()+ else reifyIDE $ \ideR session -> do+ dialog <- fileChooserDialogNew+ (Just $ "Save File")+ (Just window)+ FileChooserActionSave+ [("gtk-cancel" --buttons to display+ ,ResponseCancel) --you can use stock buttons+ ,("gtk-save"+ , ResponseAccept)]+ widgetShow dialog+ response <- dialogRun dialog+ mbFileName <- case response of+ ResponseAccept -> fileChooserGetFilename dialog+ ResponseCancel -> return Nothing+ ResponseDeleteEvent-> return Nothing+ _ -> return Nothing+ widgetDestroy dialog+ case mbFileName of+ Nothing -> return ()+ Just fn -> do+ dfe <- doesFileExist fn+ resp <- if dfe+ then do md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsYesNo+ "File already exist. Overwrite?"+ resp <- dialogRun md+ widgetHide md+ return resp+ else return ResponseYes+ case resp of+ ResponseYes -> do+ cfn <- canonicalizePath fn+ fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy cfn++ reflectIDE (do+ close currentBuffer+ newTextBuffer panePath (takeFileName fn) (Just cfn)+ ) ideR session+ return ()+ ResponseNo -> return ()+ _ -> return () where fileSave' :: Bool -> Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO() fileSave' forceLineEnds removeTBlanks ideBuf bs ct fn = do