leksah 0.4.0.3 → 0.4.1
raw patch · 33 files changed
+1602/−832 lines, 33 filesdep ~Cabal
Dependency ranges changed: Cabal
Files
- data/Default.keymap +20/−6
- data/Default.menu +5/−1
- data/Default.prefs +6/−2
- doc/leksah_manual.pdf binary
- leksah.cabal +19/−18
- src/Data/Binary/Shared.hs +162/−0
- src/Graphics/UI/Editor/Simple.hs +2/−1
- src/Graphics/UI/Frame/ViewFrame.hs +2/−2
- src/IDE/Completion.hs +326/−0
- src/IDE/Core/State.hs +29/−3
- src/IDE/Core/Types.hs +45/−16
- src/IDE/FileUtils.hs +25/−5
- src/IDE/Find.hs +7/−8
- src/IDE/Leksah.hs +64/−52
- src/IDE/Menu.hs +15/−6
- src/IDE/Metainfo/InterfaceCollector.hs +12/−179
- src/IDE/Metainfo/Provider.hs +62/−8
- src/IDE/Metainfo/Serializable.hs +212/−0
- src/IDE/Metainfo/SourceCollector.hs +138/−102
- src/IDE/NotebookFlipper.hs +141/−0
- src/IDE/Package.hs +25/−0
- src/IDE/Pane/Callers.hs +2/−14
- src/IDE/Pane/ClassHierarchy.hs +1/−12
- src/IDE/Pane/Info.hs +59/−163
- src/IDE/Pane/Log.hs +4/−17
- src/IDE/Pane/Modules.hs +3/−14
- src/IDE/Pane/PackageEditor.hs +2/−15
- src/IDE/Pane/PackageFlags.hs +1/−14
- src/IDE/Pane/Preferences.hs +53/−22
- src/IDE/Pane/Search.hs +31/−41
- src/IDE/Pane/SourceBuffer.hs +113/−105
- src/IDE/PrinterParser.hs +4/−5
- src/MyMissing.hs +12/−1
data/Default.keymap view
@@ -1,7 +1,10 @@---Default Keymap file for Genuine Haskell Face+--Default Keymap file for Leksah --Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose> --<apple> is the Windows key on PC keyboards --<compose> is often labelled Alt Gr.+--The defined values for the keys can can be found at+-- http://gitweb.freedesktop.org/?p=xorg/proto/x11proto.git;a=blob_plain;f=keysymdef.h.+-- The names of the keys are the names of the macros without the prefix. --File@@ -12,9 +15,10 @@ <ctrl>s -> FileSave "Saves the current buffer" --<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer" -<ctrl><shift>s -> FileSaveAs "Saves the current buffer as a new file" --<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file" +<ctrl><shift>s -> FileSaveAll "Saves all modified buffers"+ <ctrl>w -> FileClose "Closes the current buffer" --<ctrl>x/k -> FileClose "Closes the current buffer" @@ -75,14 +79,24 @@ <ctrl><shift>j -> PreviousError <ctrl>m -> ShowModules-<ctrl>i -> ShowInterface-<ctrl>i -> ShowInfo +--<ctrl>i -> ShowInterface+-- <ctrl>i -> ShowInfo++ <ctrl><shift>e -> EditAlignEqual <ctrl><shift>l -> EditAlignLeftArrow <ctrl><shift>r -> EditAlignRightArrow <ctrl><shift>t -> EditAlignTypeSig --- <alt>i -> AddOneImport--- <alt><shift>i -> AddAllImports+<alt>i -> AddOneImport+<alt><shift>i -> AddAllImports++-- "For the next to entries the <ctrl> modifier is mandatory"+<ctrl>Page_Up -> FlipUp "Switch to next pane in reverse recently used oder"+<ctrl>Page_Down -> FlipDown "Switch to next pane in recently used oder"++<ctrl>space -> StartComplete "Initiate complete in a source buffer"++
@@ -4,7 +4,8 @@ <menuitem name="_New" action="FileNew" /> <menuitem name="_Open" action="FileOpen" /> <menuitem name="_Save" action="FileSave" />- <menuitem name="Save_As" action="FileSaveAs" />+ <menuitem name="Save _As" action="FileSaveAs" />+ <menuitem name="Save _All" action="FileSaveAll" /> <menuitem name="_Revert" action="FileRevert" /> <menuitem name="_Close" action="FileClose" /> <separator/>@@ -133,4 +134,7 @@ <separator/> </placeholder> </toolbar>+ <accelerator name="FlipUp" action="FlipUp"/>+ <accelerator name="FlipDown" action="FlipDown"/>+ <accelerator name="StartComplete" action="StartComplete"/> </ui>
data/Default.prefs view
@@ -9,7 +9,7 @@ True Remove trailing blanks when saving a file: True-Source candy: Default+Source candy: "Default" --Empty for do not use or the name of a candy file in a config dir Name of the keymap: Default@@ -19,7 +19,8 @@ Window default size: (800,800) --Default size of the main ide window specified as pair (int,int)-Browser: "firefox"+Use ctrl Tab for Notebook flipper:+ True Standard source pane path: [LeftP] Standard log pane path:@@ -34,3 +35,6 @@ True Update metadata at startup: True+Browser: "firefox"+URL for searching documentation:+ "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query="
− doc/leksah_manual.pdf
binary file changed (1782132 → absent bytes)
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.4.0.3+version: 0.4.1 cabal-version: >=1.4 build-type: Custom license: GPL@@ -10,7 +10,7 @@ bytestring >=0.9.0.1, binary >=0.4.4, ghc >=6.10.1, glib >=0.10, gtk >=0.10, directory >=1.0.0.2, pretty >=1.0.1.0, containers >=0.2.0.0, process >=1.0.1.0, mtl >=1.1.0.2,- parsec >=2.1.0.1, Cabal >=1.6.0.1, filepath >=1.1.0.1,+ parsec >=2.1.0.1, Cabal ==1.6.0.1, filepath >=1.1.0.1, base >=4.0.0.0, old-time >=1.0.0.1, gtksourceview2 >=0.10.0 stability: provisional homepage: http://www.leksah.org@@ -30,12 +30,12 @@ data/ide_newtype.png data/ide_reexported.png data/ide_other.png data/ide_rule.png data/ide_run.png data/ide_slot.png data/ide_source.png data/ide_type.png data/leksah.png- doc/leksah_manual.pdf Readme LICENSE data/LICENSE+ Readme LICENSE data/LICENSE data/Module.template data-dir: "" extra-source-files: Setup.lhs extra-tmp-files:- + executable: leksah main-is: Main.hs buildable: True@@ -53,20 +53,21 @@ install-includes: include-dirs: hs-source-dirs: src-other-modules: IDE.Metainfo.GHCUtils MyMissing DeepSeq Default- Control.Event Graphics.UI.Editor.Parameters- Graphics.UI.Editor.Composite Graphics.UI.Editor.Basics- Graphics.UI.Editor.MakeEditor Graphics.UI.Editor.Simple- Graphics.UI.Frame.ViewFrame Graphics.UI.Frame.Panes IDE.Leksah- IDE.PrinterParser IDE.FileUtils IDE.Menu IDE.DescriptionPP IDE.Find- IDE.SourceCandy IDE.Package IDE.SpecialEditors IDE.GUIHistory- IDE.SaveSession IDE.Keymap IDE.Exception IDE.Pane.Modules- IDE.Pane.PackageEditor IDE.Pane.Log IDE.Pane.Search IDE.Pane.Info- IDE.Pane.SourceBuffer IDE.Pane.Preferences IDE.Pane.Callers- IDE.Pane.ClassHierarchy IDE.Pane.PackageFlags- IDE.Metainfo.SourceCollector IDE.Metainfo.Provider- IDE.Metainfo.InterfaceCollector IDE.Core.Types IDE.Core.State-+other-modules: IDE.Metainfo.Serializable Data.Binary.Shared+ MyMissing Default Main DeepSeq Graphics.UI.Editor.Simple+ Graphics.UI.Editor.Parameters Graphics.UI.Editor.Basics+ Graphics.UI.Editor.Composite Graphics.UI.Editor.MakeEditor+ Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame Control.Event+ IDE.Package IDE.Keymap IDE.PrinterParser IDE.Exception+ IDE.SpecialEditors IDE.SaveSession IDE.Leksah IDE.DescriptionPP+ IDE.Find IDE.Menu IDE.Completion IDE.FileUtils IDE.SourceCandy+ IDE.GUIHistory IDE.NotebookFlipper IDE.Pane.PackageFlags+ IDE.Pane.Info IDE.Pane.ClassHierarchy IDE.Pane.SourceBuffer+ IDE.Pane.Modules IDE.Pane.Preferences IDE.Pane.Log IDE.Pane.Callers+ IDE.Pane.Search IDE.Pane.PackageEditor IDE.Metainfo.Provider+ IDE.Metainfo.SourceCollector IDE.Metainfo.InterfaceCollector+ IDE.Metainfo.GHCUtils IDE.Core.State IDE.Core.Types Data.Binary.Shared+ IDE.Metainfo.Serializable ghc-prof-options: -prof -auto-all ghc-shared-options: -prof -auto-all ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns
@@ -0,0 +1,162 @@+{-# OPTIONS_GHC+ -XExistentialQuantification+ -XDeriveDataTypeable+ -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : Data.Binary.Shared+-- Copyright : 2007-2009 Jürgen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : Jutaro <jutaro@leksah.org>+-- Stability : provisional+-- Portability :+--+-- | Binary serializing with sharing+--+-----------------------------------------------------------------------------++module Data.Binary.Shared (+ BinaryShared(..)+, encodeFileSer+, encodeSer+, decodeSer+) where++import Data.Typeable (typeRepKey,cast,Typeable(..))+import qualified Control.Monad.State as St (StateT(..),get,put)+import Data.Map (Map(..))+import qualified Data.Map as Map (empty,fromDistinctAscList,toAscList,Map(..),insert,lookup)+import Data.IntMap (IntMap(..))+import qualified Data.IntMap as IMap (empty,IntMap(..),insert,lookup)+import qualified Data.Binary as Bin (getWord8,putWord8,Get(..),Binary(..))+import Data.Binary.Put (runPut,PutM(..),putWord64be)+import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.Trans (lift)+import MyMissing (forceJust)+import Control.Monad (liftM2,replicateM,liftM)+import qualified Data.Set as Set (fromDistinctAscList,toAscList,Set(..))+import qualified Data.ByteString.Lazy as L+import Data.ByteString (ByteString(..))+import Control.Monad.State.Lazy (evalStateT)+import Data.Binary.Get (runGet,getWord64be)++-- | A class for storing Binary instances with shared nodes.+-- Cycles are not supported, cause put and get is a one path process.++class (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => BinaryShared alpha where+ -- | Encode a value in the Put monad.+ put :: alpha -> PutShared++ putShared :: (alpha -> PutShared) -> alpha -> PutShared+ putShared fput v = do+ (dict, unique) <- St.get+ case (ObjC v) `Map.lookup` dict of+ Just i -> lift (Bin.putWord8 0 >> putWord64be (fromIntegral i))+ Nothing -> do+ St.put (dict,unique + 1)+ lift (Bin.putWord8 1)+ lift (putWord64be (fromIntegral unique))+ fput v+ (dict2, unique2) <- St.get+ let newDict = Map.insert (ObjC v) unique dict2+ St.put (newDict,unique2)++ -- | Decode a value in the Get monad+ get :: GetShared alpha++ getShared :: GetShared alpha -> GetShared alpha+ getShared f = do+ dict <- St.get+ w <- lift Bin.getWord8+ case w of+ 0 -> do+ i <- lift (liftM fromIntegral (getWord64be))+ case IMap.lookup i dict of+ Just (ObjC obj) -> return (forceJust (cast obj)+ "Shared>>getShared: Cast failed")+ Nothing -> error $ "Shared>>getShared : Dont find in Map " ++ show i+ 1 -> do+ i <- lift (liftM fromIntegral (getWord64be))+ obj <- f+ dict2 <- St.get+ St.put (IMap.insert i (ObjC obj) dict2)+ return obj+ _ -> error $ "Shared>>getShared : Encoding error"+++-- * How to call this++encodeSer :: BinaryShared a => a -> L.ByteString+encodeSer v = runPut (evalStateT (put v) (Map.empty,0))++encodeFileSer :: BinaryShared a => FilePath -> a -> IO ()+encodeFileSer f v = L.writeFile f (encodeSer v)++decodeSer :: BinaryShared alpha => L.ByteString -> alpha+decodeSer = runGet (evalStateT get IMap.empty)++-- * The types needed internally++data Object = forall alpha. (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => ObjC {unObj :: alpha}++instance Eq Object where+ (ObjC a) == (ObjC b) = if typeOf a /= typeOf b+ then False+ else (Just a) == cast b++instance Ord Object where+ compare (ObjC a) (ObjC b) = if typeOf a /= typeOf b+ then compare ((unsafePerformIO . typeRepKey . typeOf) a)+ ((unsafePerformIO . typeRepKey . typeOf) b)+ else compare (Just a) (cast b)++type PutShared = St.StateT (Map Object Int, Int) PutM ()+type GetShared = St.StateT (IntMap Object) Bin.Get++-----------+-- * Some standard instances, but very incomplete++instance BinaryShared a => BinaryShared [a] where+ put = putShared (\l -> lift (Bin.put (length l)) >> mapM_ put l)+ get = getShared (do+ n <- lift (Bin.get :: Bin.Get Int)+ replicateM n get)++instance (BinaryShared a) => BinaryShared (Maybe a) where+ put Nothing = lift (Bin.putWord8 0)+ put (Just x) = lift (Bin.putWord8 1) >> put x+ get = do+ w <- lift (Bin.getWord8)+ case w of+ 0 -> return Nothing+ _ -> liftM Just get++instance (BinaryShared a, BinaryShared b) => BinaryShared (a,b) where+ put (a,b) = put a >> put b+ get = liftM2 (,) get get++instance BinaryShared a => BinaryShared (Set.Set a) where+ put s = put (Set.toAscList s)+ get = liftM Set.fromDistinctAscList get++instance (BinaryShared k, BinaryShared e) => BinaryShared (Map.Map k e) where+ put m = put (Map.toAscList m)+ get = liftM Map.fromDistinctAscList get++instance BinaryShared Char where+ put = lift . Bin.put+ get = lift Bin.get++instance BinaryShared Int where+ put = lift . Bin.put+ get = lift Bin.get++instance BinaryShared Integer where+ put = lift . Bin.put+ get = lift Bin.get++instance BinaryShared ByteString where+ put = lift . Bin.put+ get = lift Bin.get+
src/Graphics/UI/Editor/Simple.hs view
@@ -312,7 +312,8 @@ core <- readIORef coreRef case core of Nothing -> do- (combo,ls) <- New.comboBoxNewText show list+ combo <- New.comboBoxNewText+ mapM_ (\o -> comboBoxAppendText combo (show o)) list widgetSetName combo (getParameter paraName parameters) mapM_ (activateEvent (castToWidget combo) notifier Nothing) [FocusOut,FocusIn]
src/Graphics/UI/Frame/ViewFrame.hs view
@@ -54,7 +54,7 @@ , newNotebook -- * Accessing GUI elements-, widgetFromPath+--, widgetFromPath , getUIAction , widgetGet @@ -96,7 +96,7 @@ selectedPanes <- getPanes if null selectedPanes || length selectedPanes > 1 then return Nothing- else (return (Just $head selectedPanes))+ else (return (Just $ head selectedPanes)) getPanes :: RecoverablePane alpha beta delta => delta ([alpha]) getPanes = do
+ src/IDE/Completion.hs view
@@ -0,0 +1,326 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.Completion+-- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : <maintainer@leksah.org>+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Completion (complete, cancel) where++import Data.List as List+import Data.Char+import Data.IORef+import Control.Monad+import Control.Monad.Trans (liftIO)+import Control.Concurrent+import Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.SourceView+import Graphics.UI.Gtk.ModelView as New+import Graphics.UI.Gtk.Gdk.Events as Gtk+import IDE.Core.State+import IDE.Metainfo.Provider(getDescription,getCompletionOptions)++complete :: SourceView -> Bool -> IDEAction+complete sourceView always = do+ currentState' <- readIDE currentState+ prefs' <- readIDE prefs+ case currentState' of+ IsCompleting window tv ls _ -> updateOptions window tv ls sourceView+ IsRunning -> when (always || not (completeRestricted prefs'))+ (initCompletion sourceView)+ _ -> return ()+++cancel :: IDEAction+cancel = do+ currentState' <- readIDE currentState+ case currentState' of+ IsCompleting window tv ls c -> cancelCompletion window tv ls c+ _ -> return ()++initCompletion :: SourceView -> IDEAction+initCompletion sourceView = do+ mainWindow <- readIDE window+ prefs <- readIDE prefs+ (window', tree', store', cids) <- reifyIDE (\ideR -> do+ window <- windowNewPopup+ --set window [ windowTypeHint := WindowTypeHintDialog ] --,+ -- windowDecorated := False ]+ --widgetSetSizeRequest window 700 300+ windowSetTransientFor window mainWindow+ paned <- hPanedNew+ containerAdd window paned+ scrolledWindow <- scrolledWindowNew Nothing Nothing+ widgetSetSizeRequest scrolledWindow 300 300+ containerAdd paned scrolledWindow+ tree <- New.treeViewNew+ containerAdd scrolledWindow tree+ store <- New.listStoreNew []+ New.treeViewSetModel tree store++ font <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f+ widgetModifyFont tree (Just font)++ column <- New.treeViewColumnNew+ set column [ New.treeViewColumnSizing := New.TreeViewColumnAutosize ]+ New.treeViewAppendColumn tree column+ renderer <- New.cellRendererTextNew+ New.treeViewColumnPackStart column renderer True+ cellLayoutSetAttributes column renderer store (\name -> [ New.cellText := name ])++ set tree [New.treeViewHeadersVisible := False]++ descriptionView <- sourceViewNew+ descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)+ lm <- sourceLanguageManagerNew+ mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")+ case mbLang of+ Nothing -> return ()+ Just lang -> do sourceBufferSetLanguage descriptionBuffer lang++ -- This call is here because in the past I have had problems where the+ -- language object became invalid if the manager was garbage collected+ sourceLanguageManagerGetLanguageIds lm++ sourceBufferSetHighlightSyntax descriptionBuffer True+ widgetModifyFont descriptionView (Just font)++ containerAdd paned descriptionView++ visible <- newIORef False+ activeView <- newIORef Nothing++ treeSelection <- New.treeViewGetSelection tree++ treeSelection `onSelectionChanged` (do+ New.treeSelectionSelectedForeach treeSelection (\treePath -> (do+ rows <- New.treeSelectionGetSelectedRows treeSelection+ case rows of+ [treePath] -> withWord store treePath (\name -> do+ description <- reflectIDE (getDescription name) ideR+ textBufferSetText descriptionBuffer description+ )+ _ -> return ()+ ))+ )++ tree `onRowActivated` (\treePath column -> (do+ withWord store treePath (\name -> do+ buffer <- textViewGetBuffer sourceView+ (start, end) <- textBufferGetSelectionBounds buffer+ isWordEnd <- textIterEndsWord end+ if isWordEnd then (do+ moveToWordStart start+ wordStart <- textBufferGetText buffer start end True+ if (isPrefixOf wordStart name) then (do+ textBufferDelete buffer start end+ textBufferInsert buffer start name+ )+ else return ()+ )+ else return ()+ )+ reflectIDE cancel ideR+ ))++ cidPress <- sourceView `onKeyPress` (\event -> do+ let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event+ Just model <- New.treeViewGetModel tree+ selection <- New.treeViewGetSelection tree+ count <- New.treeModelIterNChildren model Nothing+ Just column <- New.treeViewGetColumn tree 0+ case (name, modifier, char) of+-- ("space", [Gtk.Control], _) -> (do+-- reflectIDE (complete sourceView ) ideR+-- return True+-- )+ ("Tab", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ case maybeRow of+ Just row -> New.treeViewRowActivated tree [row] column+ Nothing -> return ()+ return True+ )+ else return False+ )+ ("Return", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ case maybeRow of+ Just row -> (do+ New.treeViewRowActivated tree [row] column+ return True+ )+ Nothing -> (do+ reflectIDE cancel ideR+ return False+ )+ )+ else return False+ )+ ("Down", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ let newRow = maybe 0 (\row -> row + 1) maybeRow+ when (newRow < count) (do+ New.treeSelectionSelectPath selection [newRow]+ New.treeViewScrollToCell tree [newRow] column Nothing+ -- Crazy hack to avoid the horizontal scroll+ New.treeViewScrollToCell tree [newRow] column Nothing+ )+ return True+ )+ else return False+ )+ ("Up", _, _) -> (do+ visible <- get tree widgetVisible+ if visible then (do+ maybeRow <- getRow tree+ let newRow = maybe 0 (\row -> row - 1) maybeRow+ when (newRow >= 0) (do+ New.treeSelectionSelectPath selection [newRow]+ New.treeViewScrollToCell tree [newRow] column Nothing+ -- Crazy hack to avoid the horizontal scroll+ New.treeViewScrollToCell tree [newRow] column Nothing+ )+ return True+ )+ else return False+ )+ (_, _, Just c) | ((isAlphaNum c) || (c == '.') || (c == '_')) -> (do+ return False+ )+ ("BackSpace", _, _) -> (do+ return False+ )+ (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") -> (do+ return False+ )+ _ -> (do+ reflectIDE cancel ideR+ return False+ )+ )++ cidRelease <- sourceView `onKeyRelease` (\event -> do+ let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event+ case (name, modifier, char) of+ ("BackSpace", _, _) -> (do+ reflectIDE (complete sourceView False) ideR+ return False+ )+ _ -> return False+ )++ return (window, tree, store, [cidPress, cidRelease])+ )++ modifyIDE_ (\ide -> return (ide{currentState = IsCompleting window' tree' store' (map ConnectC cids)}))+ updateOptions window' tree' store' sourceView++ where+ withWord store treePath f = (do+ case treePath of+ [row] -> (do+ value <- New.listStoreGetValue store row+ f value+ )+ _ -> return ()+ )++cancelCompletion :: TreeViewClass alpha => Window -> alpha ->+ ListStore String -> Connections -> IDEAction+cancelCompletion window tree store connections = do+ liftIO (do+ signalDisconnectAll connections+ widgetHideAll window+ widgetDestroy window+ )+ modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))++updateOptions :: TreeViewClass alpha => Window -> alpha -> ListStore String -> SourceView -> IDEAction+updateOptions window tree store sourceView =+ reifyIDE (\ideR -> do+ buffer <- textViewGetBuffer sourceView+ New.listStoreClear (store :: ListStore String)+ (start, end) <- textBufferGetSelectionBounds buffer+ isWordEnd <- textIterEndsWord end+ when isWordEnd (do+ moveToWordStart start+ wordStart <- textBufferGetText buffer start end True+ forkIO (do+ options <- reflectIDE (getCompletionOptions wordStart) ideR+ postGUIAsync $ processResults ideR window tree store sourceView wordStart options+ return ()+ )+ return ()+ )+ )++moveToWordStart iter = do+ textIterBackwardWordStart iter+ isStart <- textIterIsStart iter+ when (not isStart) (do+ prev <- textIterCopy iter+ textIterBackwardChar prev+ maybeChar <- textIterGetChar prev+ case maybeChar of+ Just '_' -> (do+ textIterBackwardChar iter+ moveToWordStart iter+ )+ _ -> return ()+ )++processResults ideR window tree store sourceView wordStart options = do+ buffer <- textViewGetBuffer sourceView+ (start, end) <- textBufferGetSelectionBounds buffer+ isWordEnd <- textIterEndsWord end+ when isWordEnd (do+ moveToWordStart start+ newWordStart <- textBufferGetText buffer start end True+ when (isPrefixOf wordStart newWordStart) (do+ New.listStoreClear store+ forM_ (take 200 (List.filter (isPrefixOf newWordStart) options)) (New.listStoreAppend store)+ Rectangle startx starty width height <- textViewGetIterLocation sourceView start+ (x, y) <- textViewBufferToWindowCoords sourceView TextWindowWidget (startx, starty+height)+ drawWindow <- widgetGetDrawWindow sourceView+ (ox, oy) <- drawWindowGetOrigin drawWindow+ windowMove window (ox+x) (oy+y)+ when ((length options) == 1) $ New.treeViewSetCursor tree [0] Nothing+ case options of+ [] -> reflectIDE cancel ideR+ -- [(wordStart,_)] -> (cancel completion) getRow+ _ -> widgetShowAll window+ )+ )++getRow tree = do+ Just model <- New.treeViewGetModel tree+ selection <- New.treeViewGetSelection tree+ maybeIter <- New.treeSelectionGetSelected selection+ case maybeIter of+ Just iter -> (do+ [row] <- New.treeModelGetPath model iter+ return $ Just row+ )+ Nothing -> return Nothing++
src/IDE/Core/State.hs view
@@ -20,6 +20,7 @@ IDEObject , IDEEditor , IDE(..)+, IDEState(..) , IDERef , IDEM , IDEAction@@ -45,6 +46,7 @@ , activatePane , deactivatePane , deactivatePaneIfActive+, closePane , getCandyState , setCandyState@@ -67,6 +69,7 @@ ) where import Graphics.UI.Gtk hiding (get)+import Graphics.UI.Gtk.SourceView.SourceView () import Data.Map (Map) import qualified Data.Map as Map import Data.IORef@@ -125,7 +128,7 @@ , uiManager :: UIManager -- ^ the gtk uiManager , panes :: Map PaneName (IDEPane IDEM) -- ^ a map with all panes (subwindows) , activePane :: Maybe (PaneName,Connections)-, lastActiveBufferPane :: Maybe PaneName+, recentPanes :: [PaneName] , paneMap :: Map PaneName (PanePath, Connections) -- ^ a map from the pane name to its gui path and signal connections , layout :: PaneLayout -- ^ a description of the general gui layout@@ -142,7 +145,7 @@ --the second is the scope in the current package , handlers :: Map String [(Unique, IDEEvent -> IDEM IDEEvent)] -- ^ event handling table-, isShuttingDown :: Bool+, currentState :: IDEState , guiHistory :: (Bool,[GUIHistory],Int) , findbar :: Toolbar , toolbar :: Maybe Toolbar@@ -150,6 +153,12 @@ , toolbarVisible :: Bool } --deriving Show +data IDEState =+ IsStartingUp+ | IsShuttingDown+ | IsRunning+ | IsFlipping TreeView+ | IsCompleting Window TreeView (ListStore String) Connections data IDEEvent = CurrentInfo@@ -315,7 +324,8 @@ trigger (Just (paneName pane)) (case mbAP of Nothing -> Nothing Just (pn,_) -> Just pn)- ideRef <- ask+ modifyIDE_ (\ide -> return ide{recentPanes =+ paneName pane : filter (/= paneName pane) (recentPanes ide)}) return () trigger :: Maybe String -> Maybe String -> IDEAction@@ -359,6 +369,22 @@ then deactivatePane else return () +closePane :: Pane alpha IDEM => alpha -> IDEAction+closePane pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane+ modifyIDE_ (\ide -> return ide{recentPanes = filter (/= paneName pane) (recentPanes ide)}) -- get widget elements (menu)
src/IDE/Core/Types.hs view
@@ -1,4 +1,9 @@-{-# OPTIONS_GHC -XDisambiguateRecordFields -XExistentialQuantification -XRank2Types #-}+{-# OPTIONS_GHC+ -XDisambiguateRecordFields+ -XExistentialQuantification+ -XRank2Types+ -XFlexibleInstances+ -XDeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Data@@ -29,6 +34,7 @@ , PackageDescr(..) , ModuleDescr(..) , Descr(..)+, Present(..) , SpDescr(..) , DescrType(..) , descrName@@ -47,8 +53,8 @@ , SymbolTable , PackageScope , PackModule(..)-, showPackModule , parsePackModule+, showPackModule , fromPackageIdentifier , toPackageIdentifier , Location(..)@@ -77,20 +83,19 @@ import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set-import GHC(Ghc) import Default import IDE.Exception import Graphics.UI.Frame.Panes-import Data.ByteString (ByteString(..)) import Distribution.Package (PackageIdentifier(..),Dependency(..)) import Distribution.Text import Data.Map (Map(..)) import Distribution.ModuleName(ModuleName) import Distribution.Text-import qualified Data.ByteString as BS (empty)--+import qualified Data.ByteString.Char8 as BS (unpack,empty)+import Data.ByteString.Char8 (ByteString)+import MyMissing+import Data.Typeable (Typeable(..)) -- --------------------------------------------------------------------- -- IDEPackages@@ -156,6 +161,10 @@ , collectAfterBuild :: Bool , collectAtStart :: Bool , autoExtractTars :: Maybe FilePath+ , useCtrlTabFlipping :: Bool+ , docuSearchURL :: String+ , completeRestricted :: Bool+ , saveAllBeforeBuild :: Bool } deriving(Eq,Show) data SearchHint = Forward | Backward | Insert | Delete | Initial@@ -180,6 +189,8 @@ -- | Information about the world, extraced from .hi and maybe source files -- +newtype Present alpha = Present alpha+ type PackageScope = (Map PackageIdentifier PackageDescr,SymbolTable) type SymbolTable = Map Symbol [Descr] @@ -188,23 +199,28 @@ , mbSourcePathPD :: (Maybe FilePath) , exposedModulesPD :: [ModuleDescr] , buildDependsPD :: [PackageIdentifier]-} deriving Show+} deriving (Show,Typeable) +instance Show (Present PackageDescr) where+ show (Present pd) = (fromPackageIdentifier . packagePD) pd+ instance Eq PackageDescr where (== ) a b = packagePD a == packagePD b instance Ord PackageDescr where (<=) a b = packagePD a <= packagePD b - data ModuleDescr = ModuleDescr { moduleIdMD :: PackModule , mbSourcePathMD :: (Maybe FilePath) , exportedNamesMD :: (Set Symbol) -- unqualified , usagesMD :: (Map ModuleName (Set Symbol)) -- imports , idDescriptionsMD :: [Descr]-} deriving Show+} deriving (Show,Typeable) +instance Show (Present ModuleDescr) where+ show (Present md) = (show . moduleIdMD) md+ instance Eq ModuleDescr where (== ) a b = moduleIdMD a == moduleIdMD b @@ -221,8 +237,17 @@ | Reexported { descrModu' :: PackModule , impDescr :: Descr}- deriving (Show,Read)+ deriving (Show,Read,Typeable) +instance Show (Present Descr) where+ showsPrec _ (Present descr) = case mbComment descr of+ Just comment -> p . showChar '\n' . c comment . t+ Nothing -> p . showChar '\n' . t+ where p = showString "-- | " . shows (Present (descrModu' descr))+ c com = showString $ (unlines . map ((++) "-- ") . nonEmptyLines) (BS.unpack com)+ t = showString $ BS.unpack (typeInfo descr)++ isReexported :: Descr -> Bool isReexported (Reexported _ _) = True isReexported _ = False@@ -270,7 +295,7 @@ | MethodDescr {classDescrM :: Descr} | InstanceDescr {binds :: [Symbol]} --the descrName is the type Konstructor?- deriving (Show,Read,Eq,Ord)+ deriving (Show,Read,Eq,Ord,Typeable) instance Eq Descr where (== ) a b = descrName a == descrName b@@ -318,10 +343,11 @@ data PackModule = PM { pack :: PackageIdentifier , modu :: ModuleName}- deriving (Eq, Ord,Read,Show)+ deriving (Eq, Ord,Read,Show,Typeable) -showPackModule :: PackModule -> String-showPackModule (PM p m) = display p ++ ":" ++ display m+instance Show (Present PackModule) where+ showsPrec _ (Present pd) = showString ((fromPackageIdentifier . pack) pd) . showChar ':'+ . showString (display (modu pd)) parsePackModule :: String -> PackModule parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str@@ -333,6 +359,9 @@ Just mn -> (PM pi' mn) where perror s = throwIDE $ "cannot parse PackModule from " ++ s +showPackModule :: PackModule -> String+showPackModule = show. Present+ fromPackageIdentifier :: PackageIdentifier -> String fromPackageIdentifier = display @@ -347,7 +376,7 @@ , locationSCol :: Int , locationELine :: Int , locationECol :: Int-} deriving (Show,Eq,Ord,Read)+} deriving (Show,Eq,Ord,Read,Typeable) instance Default ByteString where getDefault = BS.empty
src/IDE/FileUtils.hs view
@@ -15,6 +15,7 @@ , isSubPath , findSourceFile , autoExtractTarFiles+, openBrowser ) where @@ -41,6 +42,12 @@ import IDE.Core.State import Data.Char (ord) +openBrowser :: String -> IDEAction+openBrowser url = do+ prefs' <- readIDE prefs+ liftIO $ runProcess (browser prefs') [url] Nothing Nothing Nothing Nothing Nothing+ return ()+ -- | Returns True if the second path is a location which starts with the first path isSubPath :: FilePath -> FilePath -> Bool isSubPath fp1 fp2 =@@ -84,6 +91,15 @@ createDirectory filePath return filePath +getConfigDirForLoad :: IO (Maybe FilePath)+getConfigDirForLoad = do+ d <- getHomeDirectory+ let filePath = d </> ".leksah"+ exists <- doesDirectoryExist filePath+ if exists+ then return (Just filePath)+ else return Nothing+ hasConfigDir :: IO Bool hasConfigDir = do d <- getHomeDirectory@@ -93,11 +109,15 @@ getConfigFilePathForLoad :: String -> IO FilePath getConfigFilePathForLoad fn = do- cd <- getConfigDir- ex <- doesFileExist (cd </> fn)- if ex- then return (cd </> fn)- else do+ mbCd <- getConfigDirForLoad+ case mbCd of+ Nothing -> getFromData+ Just cd -> do+ ex <- doesFileExist (cd </> fn)+ if ex+ then return (cd </> fn)+ else getFromData+ where getFromData = do dd <- getDataDir ex <- doesFileExist (dd </> "data" </> fn) if ex
src/IDE/Find.hs view
@@ -44,7 +44,6 @@ import IDE.Core.State import IDE.Pane.SourceBuffer import Data.Char (toUpper)-import Debug.Trace data FindState = FindState { entryStr :: String@@ -95,7 +94,7 @@ hideToolbar :: IDEAction hideToolbar = do- mbtb <- trace "hide tool bar" $ readIDE toolbar+ mbtb <- readIDE toolbar case mbtb of Nothing -> return () Just tb -> do@@ -253,13 +252,13 @@ replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR - spinL `afterFocusIn` (\ _ -> (reflectIDE (inBufContext True $ \_ gtkbuf currentBuffer _ -> do+ spinL `afterFocusIn` (\ _ -> (reflectIDE (inActiveBufContext True $ \_ gtkbuf currentBuffer _ -> do max <- textBufferGetLineCount gtkbuf spinButtonSetRange spinL 1.0 (fromIntegral max) return True) ideR )) - spinL `afterEntryActivate` (reflectIDE (inBufContext () $ \_ gtkbuf currentBuffer _ -> do+ spinL `afterEntryActivate` (reflectIDE (inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do line <- spinButtonGetValueAsInt spinL iter <- textBufferGetStartIter gtkbuf textIterSetLine iter (line - 1)@@ -340,7 +339,7 @@ let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in if null search then return False- else inBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do+ else inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf textBufferRemoveTagByName gtkbuf "found" i1 i2@@ -407,7 +406,7 @@ editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat =- inBufContext' False $ \_ gtkbuf currentBuffer _ -> do+ inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> do startMark <- liftIO $textBufferGetInsert gtkbuf iter <- liftIO $textBufferGetIterAtMark gtkbuf startMark iter2 <- liftIO $textIterCopy iter@@ -430,9 +429,9 @@ editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool editReplaceAll entireWord caseSensitive wrapAround search replace hint = do- res <- editReplace' entireWord caseSensitive wrapAround search replace hint True+ res <- editReplace' entireWord caseSensitive False search replace hint True if res- then editReplaceAll entireWord caseSensitive wrapAround search replace hint+ then editReplaceAll entireWord caseSensitive False search replace hint else return False red = Color 640000 10000 10000
src/IDE/Leksah.hs view
@@ -64,6 +64,7 @@ import Graphics.UI.Editor.Simple (fileEditor) --import Outputable (ppr,showSDoc) import IDE.Metainfo.GHCUtils (inGhcIO)+import IDE.NotebookFlipper (flipUp,flipDown) -- --------------------------------------------------------------------- -- Command line options@@ -118,8 +119,10 @@ else "Current.session" when (elem VersionF o) (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version)+ prefsPath <- getConfigFilePathForLoad "Default.prefs"+ prefs <- readPrefs prefsPath when (elem Sources o) (do- buildSourceForPackageDB+ buildSourceForPackageDB prefs sysMessage Normal "rebuild SourceForPackageDB") when (elem Rebuild o || elem Collect o || not (null uninstalled)) $ do inGhcIO $ do@@ -133,14 +136,14 @@ then mapM_ (collectUninstalled writeAscii version) $ map (\ (UninstalledProject x) -> x) uninstalled else do- collectInstalled' writeAscii version (elem Rebuild o)- when (not (elem NoGUI o) && not (elem VersionF o)) (startGUI sessionFilename)+ collectInstalled' prefs writeAscii version (elem Rebuild o)+ when (not (elem NoGUI o) && not (elem VersionF o)) (startGUI sessionFilename prefs) -- --------------------------------------------------------------------- -- | Start the GUI -startGUI :: String -> IO ()-startGUI sessionFilename = do+startGUI :: String -> Prefs -> IO ()+startGUI sessionFilename prefs = do trace "start gui called" $ return () st <- initGUI when rtsSupportsBoundThreads@@ -150,9 +153,7 @@ uiManager <- uiManagerNew newIcons hasConfigDir' <- hasConfigDir- when (not hasConfigDir') firstStart- prefsPath <- getConfigFilePathForLoad "Default.prefs"- prefs <- readPrefs prefsPath+ when (not hasConfigDir') $ firstStart prefs keysPath <- getConfigFilePathForLoad $ keymapName prefs ++ ".keymap" keyMap <- parseKeymap keysPath let accelActions = setKeymap (keyMap :: KeymapI) actions@@ -175,7 +176,7 @@ , uiManager = uiManager , panes = Map.empty , activePane = Nothing- , lastActiveBufferPane = Nothing+ , recentPanes = [] , paneMap = Map.empty , layout = (TerminalP Nothing (-1)) , specialKeys = specialKeys@@ -188,7 +189,7 @@ , accessibleInfo = Nothing , currentInfo = Nothing , handlers = Map.empty- , isShuttingDown = False+ , currentState = IsStartingUp , guiHistory = (False,[],-1) , findbar = findBar , toolbar = Nothing@@ -253,47 +254,58 @@ fontDescriptionSetSize fdesc (fromJust fds + 0.01) mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers -- end patch+ reflectIDE (modifyIDE_ (\ide -> return ide{currentState = IsRunning})) ideR mainGUI -- -- | Callback function for onKeyPress of the main window, so 'preprocess' any key -- handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool-handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do- bs <- getCandyState- when bs $ editKeystrokeCandy mbChar- sk <- readIDE specialKey- sks <- readIDE specialKeys+handleSpecialKeystrokes (Key { eventKeyName = name, eventModifier = mods,+ eventKeyVal = keyVal, eventKeyChar = mbChar}) = do sb <- getSBSpecialKeys- case sk of- Nothing -> do- case Map.lookup (keyVal,sort mods) sks of- Nothing -> do- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 ""- return False- Just map -> do- sb <- getSBSpecialKeys- let sym = printMods mods ++ name- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 sym- modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)}))- return True- Just (map,sym) -> do- case Map.lookup (keyVal,sort mods) map of- Nothing -> do- sb <- getSBSpecialKeys- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?"- return ()- Just (AD actname _ _ _ ideAction _ _) -> do- sb <- getSBSpecialKeys- liftIO $statusbarPop sb 1- liftIO $statusbarPush sb 1- $sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname- ideAction- modifyIDE_ (\ide -> return (ide{specialKey = Nothing}))- return True+ prefs' <- readIDE prefs+ case (name, mods) of+ (tab, [Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")+ && useCtrlTabFlipping prefs' -> do+ flipDown+ return True+ (tab, [Shift, Control]) | (tab == "Tab" || tab == "ISO_Left_Tab")+ && useCtrlTabFlipping prefs' -> do+ flipUp+ return True+ _ -> do+ bs <- getCandyState+ when bs (editKeystrokeCandy mbChar)+ sk <- readIDE specialKey+ sks <- readIDE specialKeys+ return True+ case sk of+ Nothing ->+ case Map.lookup (keyVal,sort mods) sks of+ Nothing -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 ""+ return False+ Just map -> do+ let sym = printMods mods ++ name+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 sym+ modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)}))+ return True+ Just (map,sym) -> do+ case Map.lookup (keyVal,sort mods) map of+ Nothing -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $ sym ++ printMods mods ++ name ++ "?"+ return ()+ Just (AD actname _ _ _ ideAction _ _) -> do+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1+ $ sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname+ ideAction+ modifyIDE_ (\ide -> return (ide{specialKey = Nothing}))+ return True where printMods :: [Modifier] -> String printMods [] = ""@@ -390,8 +402,8 @@ -- -- | Called when leksah ist first called (the .leksah directory does not exist) ---firstStart :: IO ()-firstStart = do+firstStart :: Prefs -> IO ()+firstStart prefs = do prefsPath <- getConfigFilePathForLoad "Default.prefs" prefs <- readPrefs prefsPath dialog <- windowNew@@ -416,7 +428,7 @@ writePrefs fp newPrefs widgetDestroy dialog mainQuit- firstBuild)+ firstBuild prefs) cancel `onClicked` (do widgetDestroy dialog mainQuit)@@ -433,11 +445,11 @@ mainGUI return () -firstBuild :: IO ()-firstBuild = let version = cProjectVersion in do- buildSourceForPackageDB- sources <- getSourcesMap+firstBuild :: Prefs -> IO ()+firstBuild prefs = let version = cProjectVersion in do+ buildSourceForPackageDB prefs+ sources <- getSourcesMap prefs libDir <- getSysLibDir- runGhc (Just libDir) $ collectInstalled' False version True+ runGhc (Just libDir) $ collectInstalled' prefs False version True
src/IDE/Menu.hs view
@@ -52,9 +52,9 @@ import IDE.Pane.Callers import Paths_leksah import IDE.GUIHistory-import Debug.Trace import IDE.Metainfo.Provider (rebuildLibInfo,rebuildActiveInfo) import IDE.Pane.Info (showInfo)+import IDE.NotebookFlipper -- -- | The Actions known to the system (they can be activated by keystrokes or menus) --@@ -69,8 +69,10 @@ fileRevert [] False ,AD "FileSave" "_Save" Nothing (Just "gtk-save") (fileSave False) [] False- ,AD "FileSaveAs" "Save_As" Nothing (Just "gtk-save_as")+ ,AD "FileSaveAs" "Save _As" Nothing (Just "gtk-save-as") (fileSave True) [] False+ ,AD "FileSaveAll" "Save A_ll" Nothing Nothing+ fileSaveAll [] False ,AD "FileClose" "_Close" Nothing (Just "gtk-close") (do fileClose; return ()) [] False ,AD "FileCloseAll" "Close All" Nothing Nothing@@ -222,6 +224,13 @@ ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") sessionClosePane [] False + ,AD "FlipDown" "Flip down" Nothing Nothing+ flipDown [] False+ ,AD "FlipUp" "Flip up" Nothing Nothing+ flipUp [] False+ ,AD "StartComplete" "StartComplete" Nothing Nothing+ startComplete [] False+ ,AD "ViewHistoryBack" "Back" Nothing (Just "gtk-go-back") historyBack [] False ,AD "ViewHistoryForth" "Forward" Nothing (Just "gtk-go-forward")@@ -248,7 +257,7 @@ menuDescription :: IO String menuDescription = do prefsPath <- getConfigFilePathForLoad "Default.menu"- res <- trace ("read from path : " ++ prefsPath) $ readFile prefsPath+ res <- readFile prefsPath return res --@@ -294,11 +303,11 @@ quit :: IDEAction quit = do saveSession :: IDEAction- modifyIDE_ (\ide -> return (ide{isShuttingDown = True}))+ modifyIDE_ (\ide -> return (ide{currentState = IsShuttingDown})) b <- fileCloseAll if b then liftIO mainQuit- else modifyIDE_ (\ide -> return (ide{isShuttingDown = False}))+ else modifyIDE_ (\ide -> return (ide{currentState = IsRunning})) -- -- | Show the about dialog@@ -315,7 +324,7 @@ license <- catch (readFile $ dd </> "LICENSE") (\ (_ :: SomeException) -> return "") aboutDialogSetLicense d $ Just license aboutDialogSetWebsite d "http://leksah.org/"- aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken (Jutaro)"]+ aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken (Jutaro)","Hamish Mackenzie"] dialogRun d widgetDestroy d return ()
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -25,6 +25,7 @@ import GHC hiding(Id,Failed,Succeeded,ModuleName) import Module hiding (PackageId,ModuleName) import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos)+import MyMissing (nonEmptyLines) import qualified Module import TcRnMonad hiding (liftIO,MonadIO) import qualified Maybes as M@@ -61,7 +62,6 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Package hiding (PackageId) import Distribution.Verbosity-import Distribution.Version import Distribution.ModuleName import Distribution.Text (simpleParse,display) import Control.Monad.Reader@@ -70,7 +70,6 @@ import System.FilePath import System.Directory import Data.List(zip4,nub)-import Data.Binary import qualified Data.ByteString.Char8 as BS import Default@@ -79,9 +78,11 @@ --import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector import IDE.Metainfo.GHCUtils(inGhc)+import IDE.Metainfo.Serializable ()+import Data.Binary.Shared metadataVersion :: Integer-metadataVersion = 3+metadataVersion = 5 data CollectStatistics = CollectStatistics { packagesTotal :: Int@@ -95,11 +96,11 @@ getDefault = CollectStatistics getDefault getDefault getDefault getDefault getDefault -collectInstalled :: Bool -> IDEAction-collectInstalled b = inGhc $ collectInstalled' False cProjectVersion b+collectInstalled :: Prefs -> Bool -> IDEAction+collectInstalled prefs b = inGhc $ collectInstalled' prefs False cProjectVersion b -collectInstalled' :: Bool -> String -> Bool -> Ghc()-collectInstalled' writeAscii version forceRebuild = do+collectInstalled' :: Prefs -> Bool -> String -> Bool -> Ghc()+collectInstalled' prefs writeAscii version forceRebuild = do session <- getSession collectorPath <- liftIO $ getCollectorPath version when forceRebuild $ liftIO $ do@@ -114,8 +115,8 @@ if null newPackages then do sysMessage Normal "Metadata collector has nothing to do" else do- liftIO $ buildSourceForPackageDB- sources <- liftIO $ getSourcesMap+ liftIO $ buildSourceForPackageDB prefs+ sources <- liftIO $ getSourcesMap prefs exportedIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info) (IPI.exposedModules info) session) newPackages hiddenIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info)@@ -301,7 +302,7 @@ else let descr = Descr{ descrName' = unpackFS $occNameFS (ifName decl)- , typeInfo' = BS.pack $ filterExtras $ showSDocUnqual $ppr decl+ , typeInfo' = BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual $ppr decl , descrModu' = PM package (last modules) , mbLocation' = Nothing , mbComment' = Nothing@@ -438,173 +439,5 @@ (if isWorkingPackage then ".packw" else ".pack") if writeAscii then writeFile (filePath ++ "dpg") (show pd)- else encodeFile filePath (metadataVersion, pd)---- ------------------------------------------------------------------------ Binary Instances for linear storage-----instance Binary PackModule where- put (PM pack' modu')- = do put pack'- put modu'- get = do pack' <- get- modu' <- get- return (PM pack' modu')--instance Binary PackageIdentifier where- put (PackageIdentifier name' version')- = do put name'- put version'- get = do name' <- get- version' <- get- return (PackageIdentifier name' version')--instance Binary Version where- put (Version branch' tags')- = do put branch'- put tags'- get = do branch' <- get- tags' <- get- return (Version branch' tags')---instance Binary PackageDescr where- put (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD')- = do put packagePD'- put exposedModulesPD'- put buildDependsPD'- put mbSourcePathPD'- get = do packagePD' <- get- exposedModulesPD' <- get- buildDependsPD' <- get- mbSourcePathPD' <- get- return (PackageDescr packagePD' exposedModulesPD' buildDependsPD'- mbSourcePathPD')--instance Binary ModuleDescr where- put (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' usagesMD'- idDescriptionsMD')- = do put moduleIdMD'- put exportedNamesMD'- put mbSourcePathMD'- put usagesMD'- put idDescriptionsMD'- get = do moduleIdMD' <- get- exportedNamesMD' <- get- mbSourcePathMD' <- get- usagesMD' <- get- idDescriptionsMD' <- get- return (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD'- usagesMD' idDescriptionsMD')--instance Binary Descr where- put (Descr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2)- = do put (1:: Int)- put descrName2- put typeInfo2- put descrModu2- put mbLocation2- put mbComment2- put details2- put (Reexported reexpModu' impDescr')- = do put (2:: Int)- put reexpModu'- put impDescr'- get = do (typeHint :: Int) <- get- case typeHint of- 1 -> do- descrName2 <- get- typeInfo2 <- get- descrModu2 <- get- mbLocation2 <- get- mbComment2 <- get- details2 <- get- return (Descr descrName2 typeInfo2 descrModu2 mbLocation2- mbComment2 details2)- 2 -> do- reexpModu' <- get- impDescr' <- get- return (Reexported reexpModu' impDescr')- _ -> throwIDE "Impossible in Binary Descr get"--instance Binary SpDescr where- put VariableDescr- = do put (1:: Int)- put (FieldDescr typeDescrF')- = do put (2:: Int)- put typeDescrF'- put (ConstructorDescr typeDescrC')- = do put (3:: Int)- put typeDescrC'- put (DataDescr constructors' fields')- = do put (4:: Int)- put constructors'- put fields'- put TypeDescr- = do put (5:: Int)- put (NewtypeDescr constructor' mbField')- = do put (6:: Int)- put constructor'- put mbField'- put (ClassDescr super' methods')- = do put (7:: Int)- put super'- put methods'- put (MethodDescr classDescrM')- = do put (8:: Int)- put classDescrM'- put (InstanceDescr binds')- = do put (9:: Int)- put binds'-- get = do (typeHint :: Int) <- get- case typeHint of- 1 -> return VariableDescr- 2 -> do- typeDescrF' <- get- return (FieldDescr typeDescrF')- 3 -> do- typeDescrC' <- get- return (ConstructorDescr typeDescrC')- 4 -> do- constructors' <- get- fields' <- get- return (DataDescr constructors' fields')- 5 -> return TypeDescr- 6 -> do- constructor' <- get- mbField' <- get- return (NewtypeDescr constructor' mbField')- 7 -> do- super' <- get- methods' <- get- return (ClassDescr super' methods')- 8 -> do- classDescrM' <- get- return (MethodDescr classDescrM')- 9 -> do- binds' <- get- return (InstanceDescr binds')- _ -> throwIDE "Impossible in Binary SpDescr get"--instance Binary Location where- put (Location locationSLine' locationSCol' locationELine' locationECol')- = do put locationSLine'- put locationSCol'- put locationELine'- put locationECol'- get = do locationSLine' <- get- locationSCol' <- get- locationELine' <- get- locationECol' <- get- return (Location locationSLine' locationSCol' locationELine' locationECol')--instance Binary ModuleName where- put = put . display- get = liftM (fromJust . simpleParse) get--instance Binary PackageName where- put (PackageName pn) = put pn- get = liftM PackageName get+ else encodeFileSer filePath (metadataVersion, pd)
src/IDE/Metainfo/Provider.hs view
@@ -15,7 +15,12 @@ --------------------------------------------------------------------------------- module IDE.Metainfo.Provider (- initInfo+ getIdentifierDescr+, getIdentifiersStartingWith+, getCompletionOptions+, getDescription++, initInfo , updateAccessibleInfo , infoForActivePackage , mayRebuildInBackground@@ -36,13 +41,12 @@ import Data.List import qualified PackageConfig as DP import Data.Maybe-import Data.Binary-import qualified Data.ByteString.Lazy as BS import Distribution.Package hiding (depends,packageId) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map)-import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL import System.Process (ProcessHandle(..),getProcessExitCode) import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle) import Control.Monad.Reader(ask)@@ -60,11 +64,59 @@ import System.IO.Unsafe (unsafePerformIO) import Text.Regex.Posix.String (execute,compile) import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos,inGhc)+import Data.Binary.Shared (decodeSer) --+-- | Lookup of an identifier description+--+getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr]+getIdentifierDescr str st1 st2 =+ let r1 = case str `Map.lookup` st1 of+ Nothing -> []+ Just r -> r+ r2 = case str `Map.lookup` st2 of+ Nothing -> []+ Just r -> r+ in r1 ++ r2++--+-- | Lookup of an identifiers starting with the specified prefix and return a list.+--+getIdentifiersStartingWith :: String -> SymbolTable -> SymbolTable -> [String]+getIdentifiersStartingWith prefix st1 st2 =+ takeWhile (isPrefixOf prefix) $+ if memberLocal || memberGlobal then+ prefix : Set.toAscList names+ else+ Set.toAscList names+ where+ (_, memberLocal, localNames) = Set.splitMember prefix (Map.keysSet st1)+ (_, memberGlobal, globalNames) = Set.splitMember prefix (Map.keysSet st2)+ names = Set.union globalNames localNames++getCompletionOptions :: String -> IDEM [String]+getCompletionOptions prefix = do+ currentInfo' <- readIDE currentInfo+ case currentInfo' of+ Nothing -> return []+ Just ((_,symbolTable1),(_,symbolTable2)) ->+ return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2++getDescription :: String -> IDEM String+getDescription name = do+ currentInfo' <- readIDE currentInfo+ case currentInfo' of+ Nothing -> return ""+ Just ((_,symbolTable1),(_,symbolTable2)) ->+ return ((foldr (\d f -> shows (Present d) . showChar '\n' . f) id+ (getIdentifierDescr name symbolTable1 symbolTable2)) "")++-- -- | Searching of metadata --+ searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr]+searchMeta _ "" _ = return [] searchMeta Local searchString searchType = do currentInfo' <- readIDE currentInfo case currentInfo' of@@ -152,7 +204,7 @@ prefs <- readIDE prefs when (collectAtStart prefs) $ do ideMessage Normal "Now updating metadata ..."- collectInstalled False+ collectInstalled prefs False ideMessage Normal "Now loading metadata ..." loadAccessibleInfo ideMessage Normal "Finished loading ..."@@ -166,6 +218,7 @@ let version = cProjectVersion in do collectorPath <- lift $ getCollectorPath version packageInfos <- inGhc $ getInstalledPackageInfos+ -- trace ("allInfos " ++ show (map (DP.unpackPackageId . DP.packageConfigId) packageInfos)) $ return () packageList <- liftIO $ mapM (loadInfosForPackage collectorPath False) (map DP.package packageInfos) let scope = foldr buildScope (Map.empty,Map.empty)@@ -363,8 +416,9 @@ if exists then catch (do file <- openBinaryFile filePath ReadMode- bs <- BS.hGetContents file- let (metadataVersion', packageInfo) = decode bs+ -- trace ("now loading metadata for package" ++ filePath) return ()+ bs <- BSL.hGetContents file+ let (metadataVersion', packageInfo) = decodeSer bs if metadataVersion /= metadataVersion' then do hClose file@@ -489,7 +543,7 @@ instance DeepSeq DescrType where deepSeq = seq -instance DeepSeq ByteString where deepSeq = seq+instance DeepSeq BS.ByteString where deepSeq = seq instance DeepSeq Version where deepSeq = seq
+ src/IDE/Metainfo/Serializable.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC+ -XScopedTypeVariables+ -XStandaloneDeriving+ -XDeriveDataTypeable #-}+ -----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.Serializable+-- Copyright : 2007-2009 Jürgen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : Jutaro <jutaro@leksah.org>+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Metainfo.Serializable (+++) where++import IDE.Core.State+import Distribution.Text (simpleParse,display)+import Control.Monad (liftM)+import Data.Maybe (fromJust)+import Data.Binary.Shared (BinaryShared(..))+import Data.Typeable (Typeable(..))+import Distribution.Package (PackageName(..),PackageIdentifier(..))+import Data.Version (Version(..))+import Distribution.ModuleName (ModuleName(..))++deriving instance Typeable PackageIdentifier+deriving instance Typeable ModuleName+deriving instance Typeable PackageName+-----------------------------------------------------------++instance BinaryShared PackModule where+ put = putShared (\ (PM pack' modu') -> do+ (put pack')+ (put modu'))+ get = getShared (do+ pack' <- get+ modu' <- get+ return (PM pack' modu'))+++instance BinaryShared PackageIdentifier where+ put = putShared (\ (PackageIdentifier name' version') -> do+ put name'+ put version')+ get = getShared (do+ name' <- get+ version' <- get+ return (PackageIdentifier name' version'))++instance BinaryShared Version where+ put = putShared (\ (Version branch' tags') -> do+ put branch'+ put tags')+ get = getShared (do+ branch' <- get+ tags' <- get+ return (Version branch' tags'))++instance BinaryShared PackageDescr where+ put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD'+ mbSourcePathPD') -> do+ put packagePD'+ put exposedModulesPD'+ put buildDependsPD'+ put mbSourcePathPD')+ get = getShared (do+ packagePD' <- get+ exposedModulesPD' <- get+ buildDependsPD' <- get+ mbSourcePathPD' <- get+ return (PackageDescr packagePD' exposedModulesPD' buildDependsPD'+ mbSourcePathPD'))++instance BinaryShared ModuleDescr where+ put = putShared (\ (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' usagesMD'+ idDescriptionsMD') -> do+ put moduleIdMD'+ put exportedNamesMD'+ put mbSourcePathMD'+ put usagesMD'+ put idDescriptionsMD')+ get = getShared (do+ moduleIdMD' <- get+ exportedNamesMD' <- get+ mbSourcePathMD' <- get+ usagesMD' <- get+ idDescriptionsMD' <- get+ return (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD'+ usagesMD' idDescriptionsMD'))++instance BinaryShared Descr where+ put (Descr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2)+ = do put (1:: Int)+ put descrName2+ put typeInfo2+ put descrModu2+ put mbLocation2+ put mbComment2+ put details2+ put (Reexported reexpModu' impDescr')+ = do put (2:: Int)+ put reexpModu'+ put impDescr'+ get = do (typeHint :: Int) <- get+ case typeHint of+ 1 -> do+ descrName2 <- get+ typeInfo2 <- get+ descrModu2 <- get+ mbLocation2 <- get+ mbComment2 <- get+ details2 <- get+ return (Descr descrName2 typeInfo2 descrModu2 mbLocation2+ mbComment2 details2)+ 2 -> do+ reexpModu' <- get+ impDescr' <- get+ return (Reexported reexpModu' impDescr')+ _ -> throwIDE "Impossible in Binary Descr get"++instance BinaryShared SpDescr where+ put VariableDescr+ = do put (1:: Int)+ put (FieldDescr typeDescrF')+ = do put (2:: Int)+ put typeDescrF'+ put (ConstructorDescr typeDescrC')+ = do put (3:: Int)+ put typeDescrC'+ put (DataDescr constructors' fields')+ = do put (4:: Int)+ put constructors'+ put fields'+ put TypeDescr+ = do put (5:: Int)+ put (NewtypeDescr constructor' mbField')+ = do put (6:: Int)+ put constructor'+ put mbField'+ put (ClassDescr super' methods')+ = do put (7:: Int)+ put super'+ put methods'+ put (MethodDescr classDescrM')+ = do put (8:: Int)+ put classDescrM'+ put (InstanceDescr binds')+ = do put (9:: Int)+ put binds'++ get = do (typeHint :: Int) <- get+ case typeHint of+ 1 -> return VariableDescr+ 2 -> do+ typeDescrF' <- get+ return (FieldDescr typeDescrF')+ 3 -> do+ typeDescrC' <- get+ return (ConstructorDescr typeDescrC')+ 4 -> do+ constructors' <- get+ fields' <- get+ return (DataDescr constructors' fields')+ 5 -> return TypeDescr+ 6 -> do+ constructor' <- get+ mbField' <- get+ return (NewtypeDescr constructor' mbField')+ 7 -> do+ super' <- get+ methods' <- get+ return (ClassDescr super' methods')+ 8 -> do+ classDescrM' <- get+ return (MethodDescr classDescrM')+ 9 -> do+ binds' <- get+ return (InstanceDescr binds')+ _ -> throwIDE "Impossible in Binary SpDescr get"++instance BinaryShared Location where+ put (Location locationSLine' locationSCol' locationELine' locationECol')+ = do put locationSLine'+ put locationSCol'+ put locationELine'+ put locationECol'+ get = do locationSLine' <- get+ locationSCol' <- get+ locationELine' <- get+ locationECol' <- get+ return (Location locationSLine' locationSCol' locationELine' locationECol')++instance BinaryShared ModuleName where+ put = put . display+ get = liftM (fromJust . simpleParse) get++instance BinaryShared PackageName where+ put (PackageName pn) = put pn+ get = liftM PackageName get+++++
src/IDE/Metainfo/SourceCollector.hs view
@@ -19,8 +19,6 @@ , sourceForPackage , parseSourceForPackageDB , getSourcesMap--, unloadGhc ) where import qualified Text.PrettyPrint.HughesPJ as PP@@ -37,28 +35,32 @@ import System.IO import Data.List (foldl',nub,delete,sort) import Data.Maybe(catMaybes)-import qualified Control.Exception as C import qualified Data.ByteString.Char8 as BS-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Control.Exception (SomeException) + import GHC hiding (idType) import SrcLoc import RdrName import OccName import DynFlags---import PackageConfig hiding (exposedModules,package)+import StringBuffer+import Bag+import ErrUtils import FastString+import Lexer hiding (lexer)+import qualified Parser as P import Outputable hiding (char)+import HscStats import IDE.Core.State import IDE.FileUtils-import IDE.Pane.Preferences-import Digraph (flattenSCCs)-import HscTypes (msHsFilePath)+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parse (readPackageDescription)+import GHC.Exception (SomeException(..)) import Distribution.Package (PackageIdentifier(..)) import Distribution.Text (display)+import DriverPipeline (preprocess)+import GHC.Show (showSpace) -- ---------------------------------------------------------------------@@ -68,34 +70,33 @@ -> PackageDescr -> Ghc (PackageDescr,Int) collectSources sourceMap pdescr = do- unloadGhc sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr) case sourceForPackage (packagePD pdescr) sourceMap of Nothing -> do sysMessage Normal $ "No source for package " ++ display (packagePD pdescr) return (pdescr,0)- Just cabalPath' -> gcatch (do- cabalPath <- liftIO $ canonicalizePath cabalPath'- let basePath = takeDirectory cabalPath+ Just cabalPath -> gcatch (do+ let basePath = normalise $ (takeDirectory cabalPath) pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription (readPackageDescription silent cabalPath))) (\(e :: SomeException) -> return emptyPackageDescription) let bis = allBuildInfo pkgDescr let buildPaths = if hasExes pkgDescr then let exeName' = exeName (head (executables pkgDescr))- in -- map (\p -> basePath </> p) $+ in map (\p -> basePath </> p) $ ("dist" </> "build" </> exeName' </> exeName' ++ "-tmp" </> "") : ("dist" </> "build" </> "autogen") : (".") : (nub $ concatMap hsSourceDirs bis)- else -- map (\p -> basePath </> p) $+ else map (\p -> basePath </> p) $ ("dist" </> "build" </> "autogen") : (".") : (nub $ concatMap hsSourceDirs bis)- let includes = {-- map (\p -> basePath </> p) $ --} nub $ concatMap includeDirs bis+ let includes = map (\p -> basePath </> p) $ nub $ concatMap includeDirs bis+ dflags <- getSessionDynFlags let dflags2 = dflags { topDir = basePath,- hscTarget = HscAsm,+ hscTarget = HscNothing, ghcMode = CompManager, ghcLink = NoLink} setSessionDynFlags dflags2@@ -105,72 +106,63 @@ ++ ["-I" ++ dir | dir <- buildPaths] ++ ["-i" ++ dir | dir <- includes] ++ ["-i" ++ dir | dir <- buildPaths]+ ++ ["-X" ++ show e | e <- nub $ concatMap extensions bis] -- trace ("flags " ++ show flags) $ return () dflags3 <- getSessionDynFlags (dflags4,_,_) <- parseDynamicFlags dflags3 (map noLoc flags)- let dflags5 = dopt_set dflags4 Opt_Haddock+ let dflags5 = dopt_set (dopt_set dflags4 Opt_Haddock) Opt_ReadUserPackageConf setSessionDynFlags dflags5- defaultCleanupHandler dflags (do- let allMods = nub (exeModules pkgDescr ++ libModules pkgDescr)- let interestingMods = map (modu . moduleIdMD) (exposedModulesPD pdescr)- sourceFiles <- liftIO $ mapM (findSourceFile++ let allMods = nub (exeModules pkgDescr ++ libModules pkgDescr)+ let exposedMods = map (modu . moduleIdMD) (exposedModulesPD pdescr)+ sourceFiles <- liftIO $ mapM (findSourceFile buildPaths ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"])- $ nub (interestingMods ++ allMods)- liftIO $ mapM_ (\(mbSf, mn) ->- case mbSf of- Nothing -> putStrLn $ "Cant find source file for " ++ mn- Just _ -> return ()) $ zip sourceFiles (map display allMods)- (newModDescrs,failureCount) <- collectSourcesForPackage pdescr (catMaybes sourceFiles)- (map display interestingMods)- let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath,- exposedModulesPD = newModDescrs}- return (nPackDescr,failureCount)))+ $ nub (exposedMods ++ allMods)+ (newModDescrs,failureCount)+ <- foldM collectSourcesForModule ([],0)+ (zip (exposedModulesPD pdescr) sourceFiles)+ let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath,+ exposedModulesPD = newModDescrs}+ return (nPackDescr,failureCount)) (\(e :: SomeException) -> do sysMessage Normal $ "source collector throwIDE1 " ++ show e ++ " in " ++ display (packagePD pdescr) ++ " missed " ++ show (length $ exposedModulesPD pdescr) return (pdescr,length $ exposedModulesPD pdescr)) - -- ------------------------------------------------------------------------ | Collect infos from sources for modules+-- | Collect infos from sources for one module -------------------------------collectSourcesForPackage :: PackageDescr -> [String] -> [String] -> Ghc ([ModuleDescr],Int)-collectSourcesForPackage pkgDescr sourceFiles interesting = do- targets <- mapM (\f -> guessTarget f Nothing) sourceFiles- setTargets targets- trace ("before depanal") $ return ()- modgraph <- depanal [] False- trace ("after depanal") $ return ()- let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing- let interestingMods = filter (\m -> elem (moduleNameString (ms_mod_name m)) interesting) orderedMods- let orderedTupels = catMaybes (map (\om -> case filter (\m -> ((moduleNameString . moduleName . ms_mod) om) ==- (display . modu . moduleIdMD) m)- (exposedModulesPD pkgDescr) of- [] -> trace ("Cant find module source " ++ (moduleNameString . moduleName . ms_mod) om) $ Nothing- (x:_) -> (Just (x,om))) interestingMods)- foldM collectSourcesForModule ([],0) orderedTupels--collectSourcesForModule :: ([ModuleDescr],Int) -> (ModuleDescr, ModSummary) -> Ghc ([ModuleDescr],Int)-collectSourcesForModule (moduleDescrs,failureCount) (modD,modsum) = gcatch (do- let filename = msHsFilePath modsum- let dynflags = ms_hspp_opts modsum- parsedMod <- parseModule modsum- let decls = (hsmodDecls . unLoc . parsedSource) $ parsedMod- let map' = convertToMap (idDescriptionsMD modD)- let commentedDecls = addComments (filterSignatures decls)- let (descrs,restMap) = foldl' collectParseInfoForDecl ([],map') commentedDecls- let newMod = modD{- idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap),- mbSourcePathMD = Just filename}- return(newMod : moduleDescrs, failureCount))- (\(e :: SomeException) -> do- sysMessage Normal $ "source collector throwIDE2 " ++ show e ++ " in " ++- msHsFilePath modsum- return (modD : moduleDescrs, failureCount + 1))+collectSourcesForModule :: ([ModuleDescr],Int)+ -> (ModuleDescr, Maybe FilePath)+ -> Ghc ([ModuleDescr],Int)+collectSourcesForModule (moduleDescrs,failureCount) (moduleDescr,mbfp) =+ case mbfp of+ Nothing -> do+ sysMessage Normal $ "No source for module " ++ (display $ modu $ moduleIdMD moduleDescr)+ return(moduleDescr : moduleDescrs, failureCount+1)+ Just fp -> do+ session <- getSession+ (_,fp) <- preprocess session (fp,Nothing)+ dynFlags <- getSessionDynFlags+ liftIO $ do+ stringBuffer <- hGetStringBuffer fp+ parseResult <- myParseModule dynFlags fp (Just stringBuffer)+ let newModD = moduleDescr{mbSourcePathMD = mbfp}+ case parseResult of+ Right (L _ (HsModule _ _ _ decls _ _ _ )) -> do+ let map' = convertToMap (idDescriptionsMD newModD)+ let commentedDecls = addComments (filterSignatures decls)+ let (descrs,restMap) = foldl collectParseInfoForDecl ([],map')+ commentedDecls+ let newModD' = newModD{+ idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap)}+ return(newModD' : moduleDescrs, failureCount)+ Left errMsg -> do+ sysMessage Normal $ "Failed to parse " ++ fp+ printBagOfErrors defaultDynFlags (unitBag errMsg)+ return (newModD : moduleDescrs, failureCount+1) where convertToMap :: [Descr] -> Map Symbol [Descr] convertToMap list =@@ -285,17 +277,17 @@ other -> elem other idTypes declTypeToString :: Show alpha => HsDecl alpha -> String-declTypeToString (TyClD _) = "TyClD"-declTypeToString (InstD _) = "InstD"-declTypeToString (DerivD _)= "DerivD"-declTypeToString (ValD _) = "ValD"-declTypeToString (SigD _) = "SigD"-declTypeToString (DefD _) = "DefD"-declTypeToString (ForD _) = "ForD"+declTypeToString (TyClD _) = "TyClD"+declTypeToString (InstD _) = "InstD"+declTypeToString (DerivD _) = "DerivD"+declTypeToString (ValD _) = "ValD"+declTypeToString (SigD _) = "SigD"+declTypeToString (DefD _) = "DefD"+declTypeToString (ForD _) = "ForD" declTypeToString (WarningD _)= "WarnD"-declTypeToString (RuleD _) = "RuleD"+declTypeToString (RuleD _) = "RuleD" declTypeToString (SpliceD _) = "SpliceD"-declTypeToString (DocD v) = "DocD " ++ show v+declTypeToString (DocD v) = "DocD " ++ show v srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation span | not (isGoodSrcSpan span)@@ -305,24 +297,29 @@ (srcSpanEndLine span) (srcSpanEndCol span) printHsDoc :: Show alpha => HsDoc alpha -> String-printHsDoc DocEmpty = ""-printHsDoc (DocAppend l r) = printHsDoc l ++ " " ++ printHsDoc r-printHsDoc (DocString str) = str-printHsDoc (DocParagraph d) = printHsDoc d ++ "\n"-printHsDoc (DocIdentifier l) = concatMap show l-printHsDoc (DocModule str) = "Module " ++ str-printHsDoc (DocEmphasis doc) = printHsDoc doc-printHsDoc (DocMonospaced doc) = printHsDoc doc-printHsDoc (DocUnorderedList l) = concatMap printHsDoc l-printHsDoc (DocOrderedList l) = concatMap printHsDoc l-printHsDoc (DocDefList li) = concatMap (\(l,r) -> printHsDoc l ++ " " ++- printHsDoc r) li-printHsDoc (DocCodeBlock doc) = printHsDoc doc-printHsDoc (DocURL str) = str-printHsDoc (DocAName str) = str-printHsDoc _ = ""+printHsDoc d = show (PPDoc d) +newtype PPDoc alpha = PPDoc (HsDoc alpha) +instance Show alpha => Show (PPDoc alpha) where+ showsPrec _ (PPDoc DocEmpty) = id+ showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r)+ showsPrec _ (PPDoc (DocString str)) = showString str+ showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n'+ showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i f -> showChar '\'' . shows i . showChar '\'') id l+ showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"'+ showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/'+ showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@'+ showsPrec _ (PPDoc (DocUnorderedList l)) =+ foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l+ showsPrec _ (PPDoc (DocOrderedList l)) =+ foldr (\(i,n) f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l])+ showsPrec _ (PPDoc (DocDefList li)) =+ foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li+ showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@'+ showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>'+ showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#'+ showsPrec _ (PPDoc _) = id instance Show RdrName where show = unpackFS . occNameFS . rdrNameOcc@@ -339,17 +336,55 @@ load LoadAllTargets return () + ---------------------------------------------------------------------+-- | Parser function copied here, because it is not exported++myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer+ -> IO (Either ErrMsg (Located (HsModule RdrName)))+myParseModule dflags src_filename maybe_src_buf+ = -------------------------- Parser ----------------+ showPass dflags "Parser" >>+ {-# SCC "Parser" #-} do++ -- sometimes we already have the buffer in memory, perhaps+ -- because we needed to parse the imports out of it, or get the+ -- module name.+ buf <- case maybe_src_buf of+ Just b -> return b+ Nothing -> hGetStringBuffer src_filename++ let loc = mkSrcLoc (mkFastString src_filename) 1 0++ case unP P.parseModule (mkPState buf loc dflags) of {++ PFailed span err -> return (Left (mkPlainErrMsg span err));++ POk pst rdr_module -> do {++ let {ms = getMessages pst};+ printErrorsAndWarnings dflags ms;+ -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1);++ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;++ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"+ (ppSourceStats False rdr_module) ;++ return (Right rdr_module)+ -- ToDo: free the string buffer later.+ }}+ -- --------------------------------------------------------------------- -- Function to map packages to file paths -- -getSourcesMap :: IO (Map PackageIdentifier [FilePath])-getSourcesMap = do+getSourcesMap :: Prefs -> IO (Map PackageIdentifier [FilePath])+getSourcesMap prefs = do mbSources <- parseSourceForPackageDB case mbSources of Just map -> return map Nothing -> do- buildSourceForPackageDB+ buildSourceForPackageDB prefs mbSources <- parseSourceForPackageDB case mbSources of Just map -> do@@ -364,10 +399,8 @@ Just (h:_) -> Just h _ -> Nothing -buildSourceForPackageDB :: IO ()-buildSourceForPackageDB = do- prefsPath <- getConfigFilePathForLoad "Default.prefs"- prefs <- readPrefs prefsPath+buildSourceForPackageDB :: Prefs -> IO ()+buildSourceForPackageDB prefs = do case autoExtractTars prefs of Nothing -> return () Just path -> do@@ -516,3 +549,6 @@ char '\n' cabalMinimalP <?> "cabal minimal"+++
+ src/IDE/NotebookFlipper.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.NotebookFlipper+-- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : <maintainer@leksah.org>+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.NotebookFlipper (+ flipDown+, flipUp+) where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as New+import Graphics.UI.Frame.Panes (IDEPane(..))+import IDE.Core.State+import Control.Monad.Trans (liftIO)+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import Control.Monad (when)+import Graphics.UI.Frame.Panes (makeActive)++flipDown :: IDEAction+flipDown = do+ currentState' <- readIDE currentState+ case currentState' of+ IsFlipping tv -> moveFlipperDown tv+ IsRunning -> initFlipper True+ _ -> return ()++flipUp :: IDEAction+flipUp = do+ currentState' <- readIDE currentState+ case currentState' of+ IsFlipping tv -> moveFlipperUp tv+ IsRunning -> initFlipper False+ _ -> return ()++-- | Moves down in the Flipper state+moveFlipperDown :: TreeViewClass alpha => alpha -> IDEAction+moveFlipperDown tree = liftIO $ do+ mbStore <- New.treeViewGetModel tree+ case mbStore of+ Nothing -> throwIDE "NotebookFlipper>>setFlipper: no store"+ Just store -> do+ n <- New.treeModelIterNChildren store Nothing+ when (n /= 0) $ do+ (cl, _) <- New.treeViewGetCursor tree+ case cl of+ (current:_) -> let next = if current == n - 1+ then 0+ else current + 1+ in New.treeViewSetCursor tree [min (n-1) next] Nothing+ [] -> New.treeViewSetCursor tree [1] Nothing++-- | Moves up in the Flipper state+moveFlipperUp :: TreeViewClass alpha => alpha -> IDEAction+moveFlipperUp tree = liftIO $ do+ mbStore <- New.treeViewGetModel tree+ case mbStore of+ Nothing -> throwIDE "NotebookFlipper>>setFlipper: no store"+ Just store -> do+ n <- New.treeModelIterNChildren store Nothing+ when (n /= 0) $ do+ (cl, _) <- New.treeViewGetCursor tree+ case cl of+ (current:_) -> let next = if current == 0+ then n - 1+ else current - 1+ in New.treeViewSetCursor tree [min (n-1) next] Nothing+ [] -> New.treeViewSetCursor tree [n-1] Nothing++-- | Initiate Filpper , If True moves down, if false up+initFlipper :: Bool -> IDEAction+initFlipper direction = do+ mainWindow <- readIDE window+ recentPanes' <- readIDE recentPanes+ tree' <- reifyIDE $ \ideR -> do+ window <- windowNewPopup+ windowSetTransientFor window mainWindow+ set window [windowResizable := True]+ frame <- frameNew+ containerAdd window frame+ tree <- New.treeViewNew++ containerAdd frame tree+ store <- New.listStoreNew recentPanes'+ New.treeViewSetModel tree store+ column <- New.treeViewColumnNew+ New.treeViewAppendColumn tree column+ renderer <- New.cellRendererTextNew+ New.treeViewColumnPackStart column renderer True+ cellLayoutSetAttributes column renderer store+ (\str -> [ New.cellText := str])++ set tree [New.treeViewHeadersVisible := False]++ cid <- onKeyRelease mainWindow $ handleKeyRelease tree ideR++ New.onRowActivated tree (\treePath column -> do+ signalDisconnect cid+ let [row] = treePath+ string <- New.listStoreGetValue store row+ reflectIDE (do+ mbPane <- mbPaneFromName string+ case mbPane of+ Just (PaneC pane) -> makeActive pane+ Nothing -> return ()) ideR+ widgetHideAll window+ widgetDestroy window)+ set window [windowWindowPosition := WinPosCenterOnParent]+ n <- New.treeModelIterNChildren store Nothing+ New.treeViewSetCursor tree [if direction then min 1 (n-1) else (n-1)] Nothing+ widgetShowAll window+ return tree+ modifyIDE_ (\ide -> return (ide{currentState = IsFlipping tree'}))+ return ()++handleKeyRelease :: TreeViewClass alpha => alpha -> IDERef -> Event -> IO (Bool)+handleKeyRelease tree ideR Key{eventKeyName = name, eventModifier = modifier, eventKeyChar = char} = do+ case (name, modifier, char) of+ (ctrl, _, _) | (ctrl == "Control_L") || (ctrl == "Control_R") -> do+ currentState' <- reflectIDE (readIDE currentState) ideR+ case currentState' of+ IsFlipping tv -> do+ (treePath, _) <- New.treeViewGetCursor tree+ Just column <- New.treeViewGetColumn tree 0+ New.treeViewRowActivated tree treePath column+ reflectIDE (modifyIDE_ (\ide -> return (ide{currentState = IsRunning}))) ideR+ return True+ _ -> return False+ (_,_,_) -> return False+handleKeyRelease tree ideR _ = return False++
src/IDE/Package.hs view
@@ -192,6 +192,30 @@ Nothing -> return ()) (\(e :: SomeException) -> putStrLn (show e)) +packageCompile :: IDEAction+packageCompile = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ ideR <- ask+ prefs <- readIDE prefs+ case mbPackage of+ Nothing -> return ()+ Just package -> do+ when (saveAllBeforeBuild prefs) $ fileSaveAll+ sb <- getSBErrors+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 "Compiling"+ unmarkCurrentError+ pid' <- reifyIDE (\ideR -> do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build","--build-to=Compile"]+ ++ buildFlags package)+ oid <- forkIO (readOut log out)+ hSetBuffering err NoBuffering+ eid <- forkIO (reflectIDE (readErrForBuild log err) ideR)+ return pid)+ when (collectAfterBuild prefs) $ mayRebuildInBackground (Just pid'))+ (\(e :: SomeException) -> putStrLn (show e))+ packageBuild :: IDEAction packageBuild = catchIDE (do mbPackage <- getActivePackage@@ -201,6 +225,7 @@ case mbPackage of Nothing -> return () Just package -> do+ when (saveAllBeforeBuild prefs) $ fileSaveAll sb <- getSBErrors liftIO $statusbarPop sb 1 liftIO $statusbarPush sb 1 "Building"
src/IDE/Pane/Callers.hs view
@@ -65,20 +65,8 @@ getTopWidget = castToWidget . topBox paneId b = "*Usage" makeActive p = activatePane p []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane+ -- | We don't recover this pane instance RecoverablePane IDECallers CallersState IDEM where
src/IDE/Pane/ClassHierarchy.hs view
@@ -66,18 +66,7 @@ getTopWidget = castToWidget . outer paneId b = "*ClassHierarchy" makeActive p = activatePane p []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> throwIDE "Pane>IDEClassHierarchy: notebook page not found: unexpected"- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDEClassHierarchy ClassHierarchyState IDEM where saveState p = return Nothing
src/IDE/Pane/Info.hs view
@@ -20,43 +20,32 @@ , setInfo , setSymbol , replayInfoHistory-, getIdentifierDescr , showInfo ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite) import Control.Monad.Reader-import System.IO import Control.Monad import Control.Monad.Trans-import System.IO---import Data.List import Data.Maybe-import qualified Data.ByteString.Char8 as BS import Data.IORef-import qualified Data.Map as Map import Data.Typeable import IDE.Core.State import Control.Event-import Graphics.UI.Editor.MakeEditor-import Graphics.UI.Editor.Simple-import Graphics.UI.Editor.Composite-import Graphics.UI.Editor.Parameters import IDE.Pane.SourceBuffer import IDE.Pane.Callers-import Graphics.UI.Editor.Basics-import MyMissing-+import IDE.FileUtils (openBrowser)+import IDE.Metainfo.Provider (getIdentifierDescr)+import Graphics.UI.Gtk.SourceView -- | An info pane description -- data IDEInfo = IDEInfo {- sw :: ScrolledWindow+ sw :: VBox , currentDescr :: IORef Descr-, injector :: Descr -> IO()-, extractor :: Descr -> Extractor Descr+, descriptionView :: SourceView } deriving Typeable data InfoState = InfoState Descr@@ -72,20 +61,7 @@ getTopWidget = castToWidget . sw paneId b = "*Info" makeActive pane = activatePane pane []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDEInfo InfoState IDEM where saveState p = do@@ -101,108 +77,7 @@ Nothing -> return () Just p -> liftIO $ bringPaneToFront p -idDescrDescr :: IDERef -> FieldDescription Descr-idDescrDescr ideR = VFD emptyParams [- HFD emptyParams [- mkField- (paraName <<<- ParaName "Identifier"- $ paraName <<<- ParaPack PackGrow- $ emptyParams)- descrName- (\ b a -> if isReexported a then a else a{descrName' = b})- (symbolEditor ideR )- , mkField- emptyParams- (stockIdFromType . descrType . details)- (\b a -> a)- imageEditor- , mkField- (paraName <<<- ParaName "Sort"- $ emptyParams)- (descrType . details)- (\b a -> a)- (comboSelectionEditor allOf)- , mkField- (paraName <<<- ParaName "Exported by"- $ paraPack <<<- ParaPack PackGrow- $ emptyParams)- (\l -> showPackModule (descrModu l))- (\ b a -> if isReexported a then a else a{descrModu' = parsePackModule b})- (stringEditor (const True))]- , mkField- (paraPack <<<- ParaPack PackGrow $ emptyParams)- (\ a -> (BS.unpack $ typeInfo a,- (case mbComment a of- Nothing -> ""- Just s -> BS.unpack s)))- (\ b a ->- (if isReexported a- then a- else a {typeInfo' = BS.pack (fst b),- mbComment' = case snd b of- "" -> Nothing- s -> Just (BS.pack s)}))- (typeAndCommentEditor ideR )] ---allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign--- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance]--typeEditor :: IDERef -> Editor String-typeEditor ideR para noti = do- ed@(wid,inj,ext) <- multilineStringEditor para noti- registerEvent noti ButtonRelease $Left (\e -> do- res <- showInfoHandler wid ideR- return e {gtkReturn = res})- return ed--typeAndCommentEditor :: IDERef -> Editor (String,String)-typeAndCommentEditor ideR para noti =- splitEditor (typeEditor ideR,- paraName <<<- ParaName "Type"- $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)- $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)- $ emptyParams)- (multilineStringEditor,- paraName <<<- ParaName "Comment"- $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)- $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)- $ emptyParams)- (paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)- $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)- $ para) noti--symbolEditor :: IDERef -> Editor String-symbolEditor ideR parameters notifier = do- window <- reflectIDE (readIDE window) ideR- ed@(w,i,ext) <- stringEditor (\_ -> True) parameters notifier- registerEvent notifier AfterKeyRelease (Left (\ event -> do- mbText <- ext- case mbText of- Just t -> do- reflectIDE (do- triggerEvent ideR (SearchMeta t)- return ()) ideR- rw <- liftIO $ getRealWidget w- when (isJust rw) $ liftIO $ do- widgetGrabFocus (fromJust rw)- editableSelectRegion (castToEditable (fromJust rw)) 0 0- editableSetPosition (castToEditable (fromJust rw)) (-1)- Nothing -> return ()- return event{gtkReturn=False}))- return ed--showInfoHandler :: Widget -> IDERef -> IO Bool-showInfoHandler wid ideR = do- mbFrame <- binGetChild (castToAlignment wid)- mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child"))- mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) - mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3")) - buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4"))- (l,r) <- textBufferGetSelectionBounds buf- symbol <- textBufferGetText buf l r True- reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR- return False- initInfo :: PanePath -> Notebook -> Descr -> IDEAction initInfo panePath nb idDescr = do panes <- readIDE panes@@ -210,6 +85,7 @@ prefs <- readIDE prefs (pane,cids) <- reifyIDE $ \ideR -> do ibox <- vBoxNew False 0+ -- Buttons bb <- hButtonBoxNew buttonBoxSetLayout bb ButtonboxSpread definitionB <- buttonNewWithLabel "Source"@@ -217,36 +93,67 @@ usesB <- buttonNewWithLabel "Usage" docuB <- buttonNewWithLabel "Docu" searchB <- buttonNewWithLabel "Find"- widgetSetSensitivity docuB False boxPackStartDefaults bb definitionB boxPackStartDefaults bb moduB boxPackStartDefaults bb usesB boxPackStartDefaults bb docuB boxPackStartDefaults bb searchB- (widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR ) idDescr- boxPackStart ibox widget PackGrow 0- boxPackEnd ibox bb PackNatural 0- --openType- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw ibox+ -- Descr View+ font <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f++ descriptionView <- sourceViewNew+ descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer)+ lm <- sourceLanguageManagerNew+ mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell")+ case mbLang of+ Nothing -> return ()+ Just lang -> do sourceBufferSetLanguage descriptionBuffer lang++ -- This call is here because in the past I have had problems where the+ -- language object became invalid if the manager was garbage collected+ sourceLanguageManagerGetLanguageIds lm++ sourceBufferSetHighlightSyntax descriptionBuffer True+ widgetModifyFont descriptionView (Just font)++ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw descriptionView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ boxPackStart ibox sw PackGrow 10+ boxPackEnd ibox bb PackNatural 10++ --openType currentDescr' <- newIORef idDescr- let info = IDEInfo sw currentDescr' injb ext- -- mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets--- widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR--- return False)+ let info = IDEInfo ibox currentDescr' descriptionView definitionB `onClicked` (reflectIDE gotoSource ideR ) moduB `onClicked` (reflectIDE gotoModule' ideR ) usesB `onClicked` (reflectIDE calledBy' ideR ) searchB `onClicked` (do- mbDescr <- ext idDescr- case mbDescr of- Nothing -> return ()- Just descr -> reflectIDE (do- triggerEvent ideR (SearchMeta (descrName' descr))- showInfo) ideR )- notebookInsertOrdered nb sw (paneName info) Nothing- widgetShowAll sw+ descr <- readIORef currentDescr'+ reflectIDE (do+ triggerEvent ideR (SearchMeta (descrName descr))+ showInfo) ideR )+ docuB `onClicked` (do+ descr <- readIORef currentDescr'+ reflectIDE (openBrowser $ docuSearchURL prefs ++ descrName descr) ideR)+ descriptionView `widgetAddEvents` [ButtonReleaseMask]+ id5 <- descriptionView `onButtonRelease`+ (\ e -> do+ buf <- textViewGetBuffer descriptionView+ (l,r) <- textBufferGetSelectionBounds buf+ symbol <- textBufferGetText buf l r True+ reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR+ return False)++ notebookInsertOrdered nb ibox (paneName info) Nothing+ widgetShowAll ibox return (info,[]) addPaneAdmin pane [] panePath liftIO $widgetGrabFocus (sw pane)@@ -306,7 +213,8 @@ oldDescr <- liftIO $ readIORef (currentDescr info) liftIO $ do writeIORef (currentDescr info) identifierDescr- (injector info) identifierDescr+ tb <- get (descriptionView info) textViewBuffer+ textBufferSetText tb (show (Present identifierDescr)) recordInfoHistory identifierDescr oldDescr getInfoCont :: IDEM (Maybe (Descr))@@ -316,18 +224,6 @@ Nothing -> return Nothing Just p -> liftIO $ readIORef (currentDescr p) >>= return . Just ------ | Lookup of an identifier description----getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr]-getIdentifierDescr str st1 st2 =- let r1 = case str `Map.lookup` st1 of- Nothing -> []- Just r -> r- r2 = case str `Map.lookup` st2 of- Nothing -> []- Just r -> r- in r1 ++ r2 -- * GUI History
src/IDE/Pane/Log.hs view
@@ -44,8 +44,8 @@ import Text.ParserCombinators.Parsec.Language (haskellStyle) import Data.List (foldl',sort,nub) import IDE.SourceCandy (getCandylessText)-import IDE.Pane.SourceBuffer (inBufContext')-import IDE.Pane.Info (getIdentifierDescr)+import IDE.Pane.SourceBuffer (inActiveBufContext')+import IDE.Metainfo.Provider (getIdentifierDescr) import Debug.Trace (trace) import Data.List (nubBy) import IDE.Pane.SourceBuffer (markErrorInSourceBuf)@@ -109,20 +109,7 @@ getTopWidget = castToWidget . scrolledWindowL paneId b = "*Log" makeActive log = activatePane log []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDELog LogState IDEM where saveState p = return (Just LogState)@@ -374,7 +361,7 @@ case mbBuf of Nothing -> return (True,Nothing) Just buf -> do- inBufContext' () $ \ _ gtkbuf _ _ -> do+ inActiveBufContext' () $ \ _ gtkbuf _ _ -> do ideMessage Normal $ "addImport " ++ show id ++ " from " ++ (render $ disp $ mod) liftIO $ do i1 <- textBufferGetStartIter gtkbuf
src/IDE/Pane/Modules.hs view
@@ -95,18 +95,7 @@ makeActive p = do activatePane p [] --liftIO $ widgetGrabFocus (descrView p)- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected"- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDEModules ModulesState IDEM where saveState p = do@@ -412,7 +401,7 @@ return () let str2 = case snd val of [] -> fst val- (m,_):_ -> showPackModule (moduleIdMD m)+ (m,_):_ -> showPackModule (moduleIdMD m) let res = isInfixOf (map toLower string) (map toLower str2) return res @@ -422,7 +411,7 @@ $ filter (\ val -> let cstr = case snd val of [] -> fst val- (m,_):_ -> showPackModule (moduleIdMD m)+ (m,_):_ -> show (Present (moduleIdMD m)) in isInfixOf (map toLower str) (map toLower cstr)) $ concatMap flatten (subForest tree)
src/IDE/Pane/PackageEditor.hs view
@@ -227,21 +227,8 @@ getAddedIndex _ = 0 getTopWidget = castToWidget . packageBox paneId b = "*Package"- makeActive p = activatePane p []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ makeActive p = activatePane p []+ close = closePane instance RecoverablePane PackagePane PackageState IDEM where saveState p = return Nothing
src/IDE/Pane/PackageFlags.hs view
@@ -61,20 +61,7 @@ getTopWidget = castToWidget . flagsBox paneId b = "*Flags" makeActive prefs = activatePane prefs []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDEFlags FlagsState IDEM where saveState p = do
src/IDE/Pane/Preferences.hs view
@@ -74,20 +74,7 @@ getTopWidget = castToWidget . prefsBox paneId b = "*Prefs" makeActive prefs = activatePane prefs []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDEPrefs PrefsState IDEM where saveState p = return Nothing@@ -261,9 +248,9 @@ $ paraSynopsis <<<- ParaSynopsis "Empty for do not use or the name of a candy file in a config dir" $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (\a -> PP.text (case a of Nothing -> ""; Just s -> s))- (do id <- identifier- return (if null id then Nothing else Just (id)))+ (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+ (do str <- stringParser+ return (if null str then Nothing else Just (str))) sourceCandy (\b a -> a{sourceCandy = b}) (maybeEditor ((stringEditor (\s -> not (null s))), paraName <<<- ParaName "Candy specification" $ emptyParams)@@ -328,14 +315,22 @@ paraName <<<- ParaName "Y" $ emptyParams)) (\a -> return ()) , mkFieldPP- (paraName <<<- ParaName "Browser" $ emptyParams)+ (paraName <<<- ParaName "Use ctrl Tab for Notebook flipper" $ emptyParams) (PP.text . show)- stringParser- browser- (\b a -> a{browser = b})- (stringEditor (\s -> not (null s)))+ boolParser+ useCtrlTabFlipping+ (\b a -> a{useCtrlTabFlipping = b})+ boolEditor (\i -> return ()) , mkFieldPP+ (paraName <<<- ParaName "Complete only on Hotkey" $ emptyParams)+ (PP.text . show)+ boolParser+ completeRestricted+ (\b a -> a{completeRestricted = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP (paraName <<<- ParaName "Standard source pane path" $ emptyParams) (PP.text . show) readParser@@ -415,6 +410,38 @@ (maybeEditor ((fileEditor (Just "~/.cabal/packages/") FileChooserActionSelectFolder "Select folder"), emptyParams) True "Yes") (\i -> return ())+ ]),+ ("Build", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName "Automatically save all files before building" $ emptyParams)+ (PP.text . show)+ boolParser+ saveAllBeforeBuild+ (\b a -> a{saveAllBeforeBuild = b})+ boolEditor+ (\i -> return ())+ ]),+ ("Help", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName "Browser" $ emptyParams)+ (PP.text . show)+ stringParser+ browser+ (\b a -> a{browser = b})+ (stringEditor (\s -> not (null s)))+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "URL for searching documentation" $+ paraSynopsis <<<- ParaSynopsis+ ("e.g Hoogle: http://www.haskell.org/hoogle/?q= or " +++ "Hayoo: http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=")+ $ emptyParams)+ (PP.text . show)+ stringParser+ docuSearchURL+ (\b a -> a{docuSearchURL = b})+ (stringEditor (\s -> not (null s)))+ (\i -> return ()) ])] instance Default PackageIdentifier where@@ -443,6 +470,10 @@ , collectAfterBuild = False , collectAtStart = True , autoExtractTars = Nothing+ , useCtrlTabFlipping = True+ , docuSearchURL = "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query="+ , completeRestricted = False+ , saveAllBeforeBuild = True } -- ------------------------------------------------------------
src/IDE/Pane/Search.hs view
@@ -29,16 +29,13 @@ import Data.IORef (writeIORef,readIORef,IORef(..)) import IDE.Pane.Info (setInfo,IDEInfo(..)) import IDE.Pane.SourceBuffer (goToDefinition)---import Debug.Trace (trace) import IDE.Metainfo.Provider (searchMeta) import Data.Maybe import Control.Monad.Reader---import Distribution.Package import Data.Typeable import IDE.Core.State import Distribution.Text(display) import Control.Event (triggerEvent)-import Debug.Trace (trace) -- | A search pane description --@@ -47,10 +44,10 @@ scrolledView :: ScrolledWindow , treeView :: New.TreeView , searchStore :: New.ListStore Descr-, searchStringRef :: IORef String , searchScopeRef :: IORef Scope , searchModeRef :: IORef SearchMode , topBox :: VBox+, entry :: Entry } deriving Typeable data SearchState = SearchState {@@ -68,24 +65,11 @@ getTopWidget = castToWidget . topBox paneId b = "*Search" makeActive p = activatePane p []- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- liftIO $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget pane)- removePaneAdmin pane+ close = closePane instance RecoverablePane IDESearch SearchState IDEM where saveState p = do- str <- liftIO $ readIORef (searchStringRef p)+ str <- liftIO $ entryGetText (entry p) mode <- liftIO $ readIORef (searchModeRef p) scope <- liftIO $ readIORef (searchScopeRef p) return (Just (SearchState str scope mode))@@ -98,7 +82,7 @@ showSearch = do m <- getSearch liftIO $ bringPaneToFront m- liftIO $ widgetGrabFocus (treeView m)+ liftIO $ widgetGrabFocus (entry m) getSearch :: IDEM IDESearch getSearch = do@@ -158,7 +142,6 @@ treeView <- New.treeViewNew New.treeViewSetModel treeView listStore - renderer3 <- New.cellRendererTextNew renderer30 <- New.cellRendererPixbufNew col3 <- New.treeViewColumnNew@@ -215,16 +198,18 @@ containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + entry <- entryNew+ box <- vBoxNew False 2 boxPackStart box scopebox PackNatural 0 boxPackStart box sw PackGrow 0- boxPackEnd box modebox PackNatural 0- stringRef <- newIORef ""+ boxPackStart box modebox PackNatural 0+ boxPackEnd box entry PackNatural 0+ scopeRef <- newIORef scope modeRef <- newIORef mode- let search = IDESearch sw treeView listStore stringRef scopeRef modeRef box+ let search = IDESearch sw treeView listStore scopeRef modeRef box entry notebookInsertOrdered nb box (paneName search) Nothing- widgetShowAll box cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive search) ideR ; return True)@@ -248,11 +233,15 @@ (reflectIDE (modeSelectionCase active) ideR ) treeView `onButtonPress` (listViewPopup ideR listStore treeView) sel `New.onSelectionChanged` do- fillInfo treeView listStore ideR- trace "search pane selection changes" $ return ()+ fillInfo search ideR+ entry `afterKeyRelease` (\ event -> do+ text <- entryGetText entry+ reflectIDE (searchMetaGUI text) ideR+ return False) return (search,[ConnectC cid1]) addPaneAdmin buf cids panePath- liftIO $widgetGrabFocus (scrolledView buf)+ liftIO $ widgetShowAll (topBox buf)+ liftIO $ widgetGrabFocus (scrolledView buf) getScope :: IDESearch -> IO Scope getScope search = readIORef (searchScopeRef search)@@ -264,14 +253,14 @@ scopeSelection scope = do search <- getSearch liftIO $ writeIORef (searchScopeRef search) scope- text <- liftIO $ readIORef (searchStringRef search)+ text <- liftIO $ entryGetText (entry search) searchMetaGUI text modeSelection :: SearchMode -> IDEAction modeSelection mode = do search <- getSearch liftIO $ writeIORef (searchModeRef search) mode- text <- liftIO $ readIORef (searchStringRef search)+ text <- liftIO $ entryGetText (entry search) searchMetaGUI text modeSelectionCase :: Bool -> IDEAction@@ -279,23 +268,23 @@ search <- getSearch oldMode <- liftIO $ readIORef (searchModeRef search) liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense}- text <- liftIO $ readIORef (searchStringRef search)+ text <- liftIO $ entryGetText (entry search) searchMetaGUI text searchMetaGUI :: String -> IDEAction searchMetaGUI str = do search <- getSearch liftIO $ bringPaneToFront search- liftIO $ writeIORef (searchStringRef search) str+ liftIO $ entrySetText (entry search) str scope <- liftIO $ getScope search mode <- liftIO $ getMode search- let mode' = if length str > 2 then mode else Exact (caseSense mode)+-- let mode' = if length str > 2 then mode else Exact (caseSense mode) descrs <- if null str then return []- else searchMeta scope str mode'+ else searchMeta scope str mode liftIO $ do New.listStoreClear (searchStore search)- mapM_ (New.listStoreAppend (searchStore search)) descrs+ mapM_ (New.listStoreAppend (searchStore search)) (take 500 descrs) listViewPopup :: IDERef -> New.ListStore Descr@@ -342,14 +331,15 @@ return (Just val) _ -> return Nothing -fillInfo :: New.TreeView- -> New.ListStore Descr+fillInfo :: IDESearch -> IDERef -> IO ()-fillInfo treeView listStore ideR = do- sel <- getSelectionDescr treeView listStore+fillInfo search ideR = do+ sel <- getSelectionDescr (treeView search) (searchStore search) case sel of- Just descr -> reflectIDE (setInfo descr) ideR+ Just descr -> do+ reflectIDE (setInfo descr) ideR+ entrySetText (entry search) (descrName descr) otherwise -> sysMessage Normal "Search>>fillInfo:no selection" setChoices :: [Descr] -> IDEAction@@ -359,6 +349,6 @@ New.listStoreClear (searchStore search) mapM_ (New.listStoreAppend (searchStore search)) descrs bringPaneToFront search- writeIORef (searchStringRef search) ""+ entrySetText (entry search) ""
src/IDE/Pane/SourceBuffer.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-}+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.SourceBuffer@@ -35,6 +35,7 @@ , fileCloseAll , fileCloseAllButPackage , fileSave+, fileSaveAll , editUndo , editRedo , editCut@@ -56,8 +57,11 @@ , markErrorInSourceBuf , inBufContext' , inBufContext+, inActiveBufContext'+, inActiveBufContext , align+, startComplete ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite)@@ -80,10 +84,14 @@ import Control.Event import IDE.FileUtils import IDE.SourceCandy+import IDE.Completion as Completion (complete,cancel)+import Debug.Trace (trace) 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(..))+import Graphics.UI.Frame.Panes (IDEPane(..))+import Data.Char (isAlphaNum) -- -- | A text editor pane description@@ -138,9 +146,9 @@ 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+ return () close pane = do makeActive pane fileClose return ()@@ -171,6 +179,15 @@ return False) priorityDefaultIdle return () +startComplete :: IDEAction+startComplete = do+ trace "start complete" return ()+ mbBuf <- maybeActiveBuf+ currentState' <- readIDE currentState+ case mbBuf of+ Nothing -> return ()+ Just buf -> complete (sourceView buf) True+ selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer) selectSourceBuf fp = do fpc <- liftIO $ canonicalizePath fp@@ -191,6 +208,14 @@ return (Just nbuf) else return Nothing +lastActiveBufferPane :: IDEM (Maybe PaneName)+lastActiveBufferPane = do+ recentPanes' <- readIDE recentPanes+ mbBufs <- mapM mbPaneFromName recentPanes'+ case (catMaybes $ map (\ (PaneC p) -> cast p) $ catMaybes mbBufs) :: [IDEBuffer] of+ (hd : _) -> return (Just (paneName hd))+ _ -> return Nothing+ goToDefinition :: Descr -> IDEAction goToDefinition idDescr = do mbAccesibleInfo <- readIDE accessibleInfo@@ -219,7 +244,7 @@ goToSourceDefinition fp mbLocation = do mbBuf <- selectSourceBuf fp when (isJust mbBuf && isJust mbLocation) $- inBufContext () $ \_ gtkbuf buf _ -> do+ inActiveBufContext () $ \_ gtkbuf buf _ -> do let location = fromJust mbLocation lines <- textBufferGetLineCount gtkbuf iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1)@@ -242,7 +267,7 @@ markErrorInSourceBuf :: Int -> Int -> String -> IDEAction markErrorInSourceBuf line column string =- inBufContext () $ \_ gtkbuf buf _ -> do+ inActiveBufContext () $ \_ gtkbuf buf _ -> do i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf textBufferRemoveTagByName gtkbuf "activeErr" i1 i2@@ -266,13 +291,14 @@ maybeActiveBuf :: IDEM (Maybe IDEBuffer) maybeActiveBuf = do- mbPane <- readIDE lastActiveBufferPane- case mbPane of- Nothing -> return Nothing- Just paneName -> do- (PaneC pane) <- paneFromName paneName+ mbActivePane <- readIDE activePane+ mbPane <- lastActiveBufferPane+ case (mbPane,mbActivePane) of+ (Just paneName1, Just (paneName2,_)) | paneName1 == paneName2 -> do+ (PaneC pane) <- paneFromName paneName1 let mbActbuf = cast pane return mbActbuf+ _ -> return Nothing standardSourcePanePath :: IDEM PanePath standardSourcePanePath = do@@ -367,6 +393,16 @@ -- events cid <- sv `afterFocusIn` (\_ -> do reflectIDE (makeActive buf) ideR ; return False)+ buffer `afterBufferInsertText`+ (\iter text -> do+ case text of+ [c] | ((isAlphaNum c) || (c == '.') || (c == '_')) -> do+ reflectIDE (Completion.complete sv False) ideR+ _ -> return ()+ )+ sv `onMoveCursor`+ (\step n select -> do reflectIDE Completion.cancel ideR)+ sv `onButtonPress` (\event -> do reflectIDE Completion.cancel ideR; return False) return (buf,[cid]) addPaneAdmin buf (map ConnectC cids) panePath liftIO $do@@ -381,12 +417,12 @@ -- end patch return buf -checkModTime :: IDEBuffer -> IDEAction+checkModTime :: IDEBuffer -> IDEM Bool checkModTime buf = do- isShuttingDown' <- readIDE isShuttingDown- if isShuttingDown'- then return ()- else do+ currentState' <- readIDE currentState+ case currentState' of+ IsShuttingDown -> return False+ _ -> do panes <- readIDE panes let name = paneName buf case fileName buf of@@ -412,13 +448,15 @@ ResponseYes -> do revert buf liftIO $ widgetHide md+ return False ResponseNo -> liftIO $ do writeIORef (modTime buf) (Just nmt) widgetHide md- _ -> do return ()- else return ()- else return ()- Nothing -> return ()+ return True+ _ -> do return False+ else return False+ else return False+ Nothing -> return False setModTime :: IDEBuffer -> IDEAction setModTime buf = do@@ -431,7 +469,7 @@ writeIORef (modTime buf) (Just nmt) fileRevert :: IDEAction-fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do+fileRevert = inActiveBufContext' () $ \ _ _ currentBuffer _ -> do revert currentBuffer revert :: IDEBuffer -> IDEAction@@ -508,28 +546,40 @@ else text) notebookSetTabLabel nb (scrolledWindow buf) label -inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha-inBufContext' def f = do+inBufContext' :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha+inBufContext' def ideBuf f = do+ (pane,_) <- guiPropertiesFromName (paneName ideBuf)+ nb <- getNotebook pane+ mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"+ return def+ Just i -> do+ gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf)+ f nb gtkbuf ideBuf i++inBufContext :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha+inBufContext def ideBuff f = inBufContext' def ideBuff (\ a b c d -> liftIO $ f a b c d)++inActiveBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha+inActiveBufContext' def f = do mbBuf <- maybeActiveBuf case mbBuf of Nothing -> return def Just ideBuf -> do- (pane,_) <- guiPropertiesFromName (paneName ideBuf)- nb <- getNotebook pane- mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)- case mbI of- Nothing -> liftIO $ do- sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"- return def- Just i -> do- gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf)- f nb gtkbuf ideBuf i+ inBufContext' def ideBuf f -inBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha ) -> IDEM alpha-inBufContext def f = inBufContext' def (\ a b c d -> liftIO $ f a b c d)+inActiveBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha+inActiveBufContext def f = inActiveBufContext' def (\ a b c d -> liftIO $ f a b c d) -fileSave :: Bool -> IDEAction-fileSave query = inBufContext' () $ \ nb _ currentBuffer i -> do+forAllBuffers_ :: (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEAction) -> IDEAction+forAllBuffers_ f = do+ bufs <- allBuffers+ forM_ bufs (\buf -> inBufContext' () buf f)++fileSaveBuffer :: Bool -> Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEAction+fileSaveBuffer query nb gtkbuf ideBuf i = do ideR <- ask window <- readIDE window bufs <- readIDE panes@@ -537,16 +587,18 @@ paneMap <- readIDE paneMap bs <- getCandyState candy <- readIDE candy- (panePath,connects) <- guiPropertiesFromName (paneName currentBuffer)- let mbfn = fileName currentBuffer+ (panePath,connects) <- guiPropertiesFromName (paneName ideBuf)+ let mbfn = fileName ideBuf 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+ then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload+ modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf+ when (modifiedOnDisk || modifiedInBuffer) $ do+ liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) ideBuf bs candy $fromJust mbfn+ setModTime ideBuf return () else reifyIDE $ \ideR -> do dialog <- fileChooserDialogNew@@ -581,10 +633,10 @@ case resp of ResponseYes -> do cfn <- canonicalizePath fn- fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy cfn+ fileSave' (forceLineEnds prefs) (removeTBlanks prefs) ideBuf bs candy cfn reflectIDE (do- close currentBuffer+ close ideBuf newTextBuffer panePath (takeFileName fn) (Just cfn) ) ideR return ()@@ -606,6 +658,12 @@ removeTrailingBlanks :: String -> String removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse +fileSave :: Bool -> IDEAction+fileSave query = inActiveBufContext' () $ fileSaveBuffer query++fileSaveAll :: IDEAction+fileSaveAll = forAllBuffers_ $ fileSaveBuffer False+ fileNew :: IDEAction fileNew = do prefs <- readIDE prefs@@ -614,7 +672,7 @@ return () fileClose :: IDEM Bool-fileClose = inBufContext' True $ fileClose'+fileClose = inActiveBufContext' True $ fileClose' fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool fileClose' nb gtkbuf currentBuffer i = do@@ -647,12 +705,7 @@ if cancel then return False else do- deactivatePane- modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Nothing}))- removePaneAdmin currentBuffer- liftIO $ do- notebookRemovePage nb i- widgetDestroy (getTopWidget currentBuffer)+ closePane currentBuffer return True @@ -751,7 +804,7 @@ return () editUndo :: IDEAction-editUndo = inBufContext () $ \_ gtkbuf _ _ ->+editUndo = inActiveBufContext () $ \_ gtkbuf _ _ -> let sb = castToSourceBuffer gtkbuf in do canUndo <- sourceBufferGetCanUndo sb if canUndo@@ -759,7 +812,7 @@ else return () editRedo :: IDEAction-editRedo = inBufContext () $ \_ gtkbuf _ _ ->+editRedo = inActiveBufContext () $ \_ gtkbuf _ _ -> let sb = castToSourceBuffer gtkbuf in do canRedo <- sourceBufferGetCanRedo sb if canRedo@@ -767,30 +820,30 @@ else return () editDelete :: IDEAction-editDelete = inBufContext () $ \_ gtkbuf _ _ -> do+editDelete = inActiveBufContext () $ \_ gtkbuf _ _ -> do textBufferDeleteSelection gtkbuf True True return () editSelectAll :: IDEAction-editSelectAll = inBufContext () $ \_ gtkbuf _ _ -> do+editSelectAll = inActiveBufContext () $ \_ gtkbuf _ _ -> do start <- textBufferGetStartIter gtkbuf end <- textBufferGetEndIter gtkbuf textBufferSelectRange gtkbuf start end editCut :: IDEAction-editCut = inBufContext () $ \_ gtkbuf _ _ -> do+editCut = inActiveBufContext () $ \_ gtkbuf _ _ -> do cb <- atomNew "GDK_SELECTION_CLIPBOARD" clip <- clipboardGet cb textBufferCutClipboard gtkbuf clip True editCopy :: IDEAction-editCopy = inBufContext () $ \_ gtkbuf _ _ -> do+editCopy = inActiveBufContext () $ \_ gtkbuf _ _ -> do cb <- atomNew "GDK_SELECTION_CLIPBOARD" clip <- clipboardGet cb textBufferCopyClipboard gtkbuf clip editPaste :: IDEAction-editPaste = inBufContext () $ \_ gtkbuf _ _ -> do+editPaste = inActiveBufContext () $ \_ gtkbuf _ _ -> do cb <- atomNew "GDK_SELECTION_CLIPBOARD" mark <- textBufferGetInsert gtkbuf iter <- textBufferGetIterAtMark gtkbuf mark@@ -813,7 +866,7 @@ return (startLine',endLineReal) doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a]-doForSelectedLines d f = inBufContext' d $ \_ gtkbuf currentBuffer _ -> liftIO $do+doForSelectedLines d f = inActiveBufContext' d $ \_ gtkbuf currentBuffer _ -> liftIO $do (start,end) <- getStartAndEndLineOfSelection gtkbuf iter <- textBufferGetStartIter gtkbuf mapM (f gtkbuf iter) [start .. end]@@ -874,19 +927,19 @@ editToCandy :: IDEAction editToCandy = do ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do+ inActiveBufContext () $ \_ gtkbuf _ _ -> do transformToCandy ct gtkbuf editFromCandy :: IDEAction editFromCandy = do ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do+ inActiveBufContext () $ \_ gtkbuf _ _ -> do transformFromCandy ct gtkbuf editKeystrokeCandy :: Maybe Char -> IDEAction editKeystrokeCandy c = do ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do+ inActiveBufContext () $ \_ gtkbuf _ _ -> do keystrokeCandy ct c gtkbuf editCandy :: IDEAction@@ -933,51 +986,6 @@ align :: Char -> IDEAction align = alignChar . transChar-------alignEqual :: IDEAction---alignEqual = alignChar '='------alignRightArrow :: IDEAction---alignRightArrow = alignChar (toEnum 0x2192) --RIGHTWARDS ARROW------alignLeftArrow :: IDEAction---alignLeftArrow = alignChar (toEnum 0x2190) --LEFTWARDS ARROW------alignTypeOf :: IDEAction---alignTypeOf = alignChar (toEnum 0x2237) --PROPORTION----guessLanguage :: Maybe FilePath -> Maybe String---guessLanguage Nothing = Just "Haskell"---guessLanguage (Just fp) =--- case takeExtension fp of--- ".c" -> Just "C"--- ".hs" -> Just "Haskell"--- ".chs" -> Just "Haskell"--- ".hsc" -> Just "Haskell"--- ".lhs" -> Just "Literate Haskell"--- ".haddock" -> Just "Haddock"--- _ -> Nothing--{---sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage)-sourceLanguageForFilename lm Nothing =- liftM (\l -> (Just "haskell", Just l)) ()-sourceLanguageForFilename lm (Just filename) =- let extension = takeExtension filename in do- ids <- sourceLanguageManagerGetLanguageIds lm- relevant <- filterM (\id -> do- lang <- sourceLanguageManagerGetLanguage lm id- globs <- sourceLanguageGetGlobs lang- return (match extension globs)) ids- case relevant of- [] -> return (Nothing,Nothing)- hd:_ -> liftM (\l -> (Just hd, Just l)) (sourceLanguageManagerGetLanguage lm hd)- where- match :: String -> [String] -> Bool- match ext = not . null . filter (== ext) . map (drop 1)---}- sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage) sourceLanguageForFilename lm Nothing = do
src/IDE/PrinterParser.hs view
@@ -35,8 +35,7 @@ import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics-import System.IO.Unsafe (unsafePerformIO)-import Control.Monad (liftM)+import Data.Maybe (listToMaybe) type Printer beta = beta -> PP.Doc@@ -103,12 +102,12 @@ str <- many (noneOf ['\n']) if null str then unexpected "read parser on empty string"- else case unsafePerformIO- (catch (liftM Just (readIO str))- (\e -> return Nothing)) of+ else do+ case maybeRead str of Nothing -> unexpected $ "read parser no parse " ++ str Just r -> return r <?> "read parser"+ where maybeRead = listToMaybe . map fst . filter (null . snd) . reads pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) pairParser p2 = do
src/MyMissing.hs view
@@ -19,9 +19,20 @@ , forceHead , split , replace+, nonEmptyLines ) where -import Data.List (unfoldr)+import Data.List (find,unfoldr)+import Data.Maybe (isJust)+import Data.Char (isSpace)++-- ---------------------------------------------------------------------+-- | A class for pretty printing+--++nonEmptyLines :: String -> [String]+nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines+ allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)]