diff --git a/data/Default.keymap b/data/Default.keymap --- a/data/Default.keymap +++ b/data/Default.keymap @@ -1,7 +1,10 @@ ---Default Keymap file for Genuine Haskell Face +--Default Keymap file for Leksah --Allowed Modifiers are -- is the Windows key on PC keyboards -- 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 @@ s -> FileSave "Saves the current buffer" --x/s -> FileSave "Saves the current buffer" -s -> FileSaveAs "Saves the current buffer as a new file" --x/w -> FileSaveAs "Saves the current buffer as a new file" +s -> FileSaveAll "Saves all modified buffers" + w -> FileClose "Closes the current buffer" --x/k -> FileClose "Closes the current buffer" @@ -75,14 +79,24 @@ j -> PreviousError m -> ShowModules -i -> ShowInterface -i -> ShowInfo +--i -> ShowInterface +-- i -> ShowInfo + + e -> EditAlignEqual l -> EditAlignLeftArrow r -> EditAlignRightArrow t -> EditAlignTypeSig --- i -> AddOneImport --- i -> AddAllImports +i -> AddOneImport +i -> AddAllImports + +-- "For the next to entries the modifier is mandatory" +Page_Up -> FlipUp "Switch to next pane in reverse recently used oder" +Page_Down -> FlipDown "Switch to next pane in recently used oder" + +space -> StartComplete "Initiate complete in a source buffer" + + diff --git a/data/Default.menu b/data/Default.menu --- a/data/Default.menu +++ b/data/Default.menu @@ -4,7 +4,8 @@ - + + @@ -133,4 +134,7 @@ + + + diff --git a/data/Default.prefs b/data/Default.prefs --- a/data/Default.prefs +++ b/data/Default.prefs @@ -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=" diff --git a/doc/leksah_manual.pdf b/doc/leksah_manual.pdf deleted file mode 100644 Binary files a/doc/leksah_manual.pdf and /dev/null differ diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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 diff --git a/src/Data/Binary/Shared.hs b/src/Data/Binary/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Shared.hs @@ -0,0 +1,162 @@ +{-# OPTIONS_GHC + -XExistentialQuantification + -XDeriveDataTypeable + -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Binary.Shared +-- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : Jutaro +-- 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 + diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs --- a/src/Graphics/UI/Editor/Simple.hs +++ b/src/Graphics/UI/Editor/Simple.hs @@ -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] diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -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 diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Completion.hs @@ -0,0 +1,326 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Completion +-- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : +-- 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 + + diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -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) diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -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 diff --git a/src/IDE/FileUtils.hs b/src/IDE/FileUtils.hs --- a/src/IDE/FileUtils.hs +++ b/src/IDE/FileUtils.hs @@ -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 diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -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 diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -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 diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs --- a/src/IDE/Menu.hs +++ b/src/IDE/Menu.hs @@ -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 () diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -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) diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs --- a/src/IDE/Metainfo/Provider.hs +++ b/src/IDE/Metainfo/Provider.hs @@ -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 diff --git a/src/IDE/Metainfo/Serializable.hs b/src/IDE/Metainfo/Serializable.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/Serializable.hs @@ -0,0 +1,212 @@ +{-# OPTIONS_GHC + -XScopedTypeVariables + -XStandaloneDeriving + -XDeriveDataTypeable #-} + ----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.Serializable +-- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : Jutaro +-- 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 + + + + + diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs --- a/src/IDE/Metainfo/SourceCollector.hs +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -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" + + + diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs new file mode 100644 --- /dev/null +++ b/src/IDE/NotebookFlipper.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.NotebookFlipper +-- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : +-- 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 + + diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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" diff --git a/src/IDE/Pane/Callers.hs b/src/IDE/Pane/Callers.hs --- a/src/IDE/Pane/Callers.hs +++ b/src/IDE/Pane/Callers.hs @@ -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 diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs --- a/src/IDE/Pane/ClassHierarchy.hs +++ b/src/IDE/Pane/ClassHierarchy.hs @@ -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 diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -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 diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -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 diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs --- a/src/IDE/Pane/Modules.hs +++ b/src/IDE/Pane/Modules.hs @@ -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) diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -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 diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -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 diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -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 } -- ------------------------------------------------------------ diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs --- a/src/IDE/Pane/Search.hs +++ b/src/IDE/Pane/Search.hs @@ -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) "" diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -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 diff --git a/src/IDE/PrinterParser.hs b/src/IDE/PrinterParser.hs --- a/src/IDE/PrinterParser.hs +++ b/src/IDE/PrinterParser.hs @@ -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 diff --git a/src/MyMissing.hs b/src/MyMissing.hs --- a/src/MyMissing.hs +++ b/src/MyMissing.hs @@ -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)]