diff --git a/data/current.lkshs b/data/current.lkshs --- a/data/current.lkshs +++ b/data/current.lkshs @@ -1,15 +1,17 @@ Version of session file format: 1 Time of storage: - "Fri Feb 26 17:11:46 CET 2010" -Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 329)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 658) 886 -Population: [(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 401 (SystemScope,True) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[6,13],[6]],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP BottomP])] -Window size: (1643,1030) + "Sun Apr 17 22:14:23 CEST 2011" +Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 198) 137)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 494) 540 +Population: [(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 286 (SystemScope,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP])] +Window size: (1076,728) +Completion size: + (750,400) Workspace: Nothing Active pane: Nothing Toolbar visible: True -FindbarState: (True,FindState {entryStr = "", entryHist = [], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) +FindbarState: (True,FindState {entryStr = "", entryHist = [""], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) Recently opened files: [] Recently opened workspaces: diff --git a/data/leksah.menu b/data/leksah.menu --- a/data/leksah.menu +++ b/data/leksah.menu @@ -1,12 +1,12 @@ - + - - + + - + @@ -43,33 +43,34 @@ - - - - + + + + - - + + - - + + + - - - + + + - - - - - + + + + + @@ -96,6 +97,7 @@ + @@ -168,7 +170,7 @@ - + diff --git a/data/module.lksht b/data/module.lksht --- a/data/module.lksht +++ b/data/module.lksht @@ -13,9 +13,8 @@ ----------------------------------------------------------------------------- module @ModuleName@ ( - - +@ModuleExports@ ) where - +@ModuleBody@ diff --git a/data/prefs.lkshp b/data/prefs.lkshp --- a/data/prefs.lkshp +++ b/data/prefs.lkshp @@ -64,10 +64,12 @@ True Background build: True -Include linking in background builds: +Make mode: True -Auto install packages: - InstallLibs +Single build without linking: + False +Don't install last package: + False Enable usage of Show instances in :print: True Break on any exception thrown: diff --git a/data/welcome.txt b/data/welcome.txt --- a/data/welcome.txt +++ b/data/welcome.txt @@ -1,48 +1,5 @@ - - $=,:Z D7,,,,,,:7$Z - $......,= +.....,+$ - =...,~:..,+D D:~~::~=$ - O~.=????????..O 8III?II$Z - :.I??????????~:N 77I??778 - ??7777777II????+?8 877??I$O - O:$$$ZDNDZ$77I??I:= I7I?I$D - Z?$D $77I?II7 87II77O - $$ 77III:$ DIIII7$ - $N O7II7=D ?7II7Z - $D $77I77 87II7$ - Z$II7Z 8I7I7$N - $777?D IIII$N - $777+ O7777Z - D$77$O I7I77 - Z$III?Z Z777$D - $7III7? DI777D - $7777777Z I77$$ - O?77$8$77I 8777$N - ?777D D77$$ O?77$N - Z77$7 $$7IO I777$ - N+77$8 N$77? Z777$ - $777O D$7$$ I777$ - 7?77$ $77+.777O - N=77$O D$7I=I7$ - 8+77$8 $7III$O - ?I777 N$7I7$ - Z7I778 N7777$ - N~II7$ $777$ - 8I7I7$D $7I7:Z - I~I77O N7II=,N Z - $III7$ $7II7,N $ - $:II7$8 $7II~~Z O7N - O~7II78 D$7I?:.=8 ~$$ - ~III7$ O77??=..? N?,,$ - O~I??7$D $7I???:.........,7 - N,~I?I77 O7I???=,.....,+$N - $,II?I7$D $7I????????I7$8 - O,:???I7D 77II?????I7$N - $.II??I7$ N77IIII77Z - DI?I77777$O Z7777$O - "The Miracle comes quietly into the mind that stops an instant and is still" - + # # ###### # #### #### # # ###### ##### #### # # # # # # # # ## ## # # # # # # ##### # # # # # ## # ##### # # # @@ -56,9 +13,10 @@ # ##### #### #### # # ###### # # # # # ###### # # # # # # # # # # # # - ###### ###### # # #### # # # # V.0.8 + ###### ###### # # #### # # # # - - - - + + "The Miracle comes quietly into the mind that stops an instant and is still" + + + diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,10 +1,10 @@ name: leksah -version: 0.10.0.1 +version: 0.10.0.3 cabal-version: >=1.8 build-type: Simple license: GPL license-file: LICENSE -copyright: 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +copyright: 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie maintainer: maintainer@leksah.org stability: provisional homepage: http://www.leksah.org @@ -14,7 +14,7 @@ description: An Integrated Development Environment for Haskell written in Haskell. category: Development, IDE, Editor author: Juergen Nicklisch-Franken, Hamish Mackenzie -tested-with: GHC ==6.10 || ==6.12 +tested-with: GHC ==6.10 || ==6.12 || ==7.0 data-files: LICENSE Readme @@ -127,7 +127,7 @@ ghc-prof-options: -auto-all -prof ghc-shared-options: -auto-all -prof - ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans + ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans Executable leksah if os(windows) @@ -167,14 +167,14 @@ ghc >=6.10.1 && <7.1, strict >= 0.3.2 && <0.4 else hs-source-dirs: main - build-depends: leksah ==0.10.0.0, base >=4.0.0.0 && <= 5 + build-depends: leksah ==0.10.0.3, base >=4.0.0.0 && <= 5 main-is: Main.hs buildable: True extensions: CPP ghc-prof-options: -auto-all -prof ghc-shared-options: -auto-all -prof - ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans + ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs --- a/src/IDE/BufferMode.hs +++ b/src/IDE/BufferMode.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.BufferMode --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL Nothing -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Build.hs b/src/IDE/Build.hs --- a/src/IDE/Build.hs +++ b/src/IDE/Build.hs @@ -21,6 +21,7 @@ makePackages, MakeSettings(..), MakeOp(..), + defaultMakeSettings ) where import Data.Map (Map) @@ -33,12 +34,13 @@ (edges, topSort, graphFromEdges, Vertex, Graph, transposeG) import Distribution.Package (pkgVersion, pkgName, Dependency(..)) -import Data.List ((\\), nub, find) +import Data.List (delete, nub, (\\), find) import Distribution.Version (withinRange) import Data.Maybe (mapMaybe) import IDE.Package (packageClean', packageInstall', buildPackage, packageConfig') -import IDE.Core.Types (InstallFlag, IDE(..), WorkspaceAction) +import IDE.Core.Types + (Prefs(..), IDE(..), WorkspaceAction) import Control.Monad.Reader import Distribution.Text (Text(..)) @@ -61,7 +63,7 @@ | MoDocu | MoOther String | MoComposed [MakeOp] - deriving Show + deriving (Eq,Ord,Show) data Chain alpha beta = Chain { @@ -73,12 +75,20 @@ deriving Show data MakeSettings = MakeSettings { - msInstallMode :: InstallFlag, - msIsSingleMake :: Bool, - msSaveAllBeforeBuild :: Bool, - msBackgroundBuild :: Bool, - msLinkingInBB :: Bool} + msMakeMode :: Bool, + msSingleBuildWithoutLinking :: Bool, + msSaveAllBeforeBuild :: Bool, + msBackgroundBuild :: Bool, + msDontInstallLast :: Bool} +defaultMakeSettings :: Prefs -> MakeSettings +defaultMakeSettings prefs = MakeSettings { + msMakeMode = makeMode prefs, + msSingleBuildWithoutLinking = singleBuildWithoutLinking prefs, + msSaveAllBeforeBuild = saveAllBeforeBuild prefs, + msBackgroundBuild = backgroundBuild prefs, + msDontInstallLast = dontInstallLast prefs} + -- ** Functions -- | Construct a dependency graph for a package @@ -87,7 +97,7 @@ constrParentGraph targets = trace ("parentGraph : " ++ showGraph parGraph) parGraph where parGraph = Map.fromList - $ map (\ p -> (p,nub $ p : mapMaybe (depToTarget targets)(ipdDepends p))) targets + $ map (\ p -> (p,nub $ mapMaybe (depToTarget targets)(ipdDepends p))) targets -- | Construct a dependency graph for a package -- pointing to the packages which depend on the subject package @@ -108,32 +118,40 @@ -- | Construct a make chain for a package, -- which is a plan of the build to perform. -- Consumes settings, the workspace and a list of targets. -constrMakeChain :: MakeSettings -> Workspace -> [IDEPackage] -> MakeOp -> Chain MakeOp IDEPackage -constrMakeChain _ _ [] _ = EmptyChain -constrMakeChain ms@MakeSettings{msIsSingleMake = isSingle} - Workspace{wsPackages = packages, wsNobuildPack = noBuilds} targets@(headTarget:restTargets) op - | isSingle = chainFor headTarget ms op EmptyChain Nothing - | otherwise = trace ("topsorted: " ++ showTopSorted topsorted) constrElem targets topsorted +constrMakeChain :: MakeSettings -> Workspace -> [IDEPackage] -> MakeOp -> MakeOp -> Chain MakeOp IDEPackage +constrMakeChain _ _ [] _ _ = EmptyChain +constrMakeChain ms@MakeSettings{msMakeMode = makeMode} + Workspace{wsPackages = packages, wsNobuildPack = noBuilds} + targets@(headTarget:restTargets) op1 op2 + | not makeMode = chainFor headTarget ms op1 EmptyChain Nothing + | otherwise = trace ("topsorted: " ++ showTopSorted topsorted) + constrElem targets topsorted depGraph ms noBuilds op1 op2 where depGraph = constrDepGraph packages - topsorted = topSortGraph depGraph - constrElem :: [IDEPackage] -> [IDEPackage] -> Chain MakeOp IDEPackage - constrElem _ [] = trace ("constrElem: 1") EmptyChain - constrElem [] _ = trace ("constrElem: 2")EmptyChain - constrElem currentTargets (current:rest) - | elem current currentTargets && not (elem headTarget noBuilds) = - let dependends = case Map.lookup current depGraph of - Nothing -> trace ("Build>>constrMakeChain: unknown package" - ++ show current) [] - Just deps -> deps - in trace ("constrElem: 3 " ++ show currentTargets ++ " " - ++ show current ++ " " ++ show rest ++ - " " ++ show dependends) $ chainFor current ms op - (constrElem (nub $ currentTargets ++ dependends) rest) (Just EmptyChain) - | otherwise = trace ("constrElem: 4 " ++ show currentTargets ++ " " - ++ show current ++ " " ++ show rest) - $ constrElem currentTargets rest + topsorted = reverse $ topSortGraph $ constrParentGraph packages +constrElem :: [IDEPackage] -> [IDEPackage] -> MakeGraph -> MakeSettings -> [IDEPackage] + -> MakeOp -> MakeOp -> Chain MakeOp IDEPackage +constrElem _ [] _ _ _ _ _ = trace ("constrElem: 1") EmptyChain +constrElem [] _ _ _ _ _ _ = trace ("constrElem: 2") EmptyChain +constrElem currentTargets (current:rest) depGraph ms noBuilds op1 op2 + | elem current currentTargets && not (elem current noBuilds) = + let dependends = case Map.lookup current depGraph of + Nothing -> trace ("Build>>constrMakeChain: unknown package" + ++ show current) [] + Just deps -> deps + withoutInstall = msDontInstallLast ms && null (delete current dependends) + filteredOps = case op1 of + MoComposed l -> MoComposed (filter (\e -> e /= MoInstall) l) + MoInstall -> MoComposed [] + other -> other + in trace ("constrElem1 deps: " ++ show dependends ++ " withoutInstall: " ++ show withoutInstall) + $ + chainFor current ms (if withoutInstall then filteredOps else op1) + (constrElem (nub $ currentTargets ++ dependends) rest depGraph ms noBuilds op2 op2) + (Just EmptyChain) + | otherwise = trace ("constrElem2 " ++ show op2) $ constrElem currentTargets rest depGraph ms noBuilds op1 op2 + chainFor :: IDEPackage -> MakeSettings -> MakeOp -> Chain MakeOp IDEPackage -> Maybe (Chain MakeOp IDEPackage) -> Chain MakeOp IDEPackage @@ -153,7 +171,8 @@ doBuildChain ms chain@Chain{mcAction = MoConfigure} = do packageConfig' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoBuild} = do - buildPackage (msBackgroundBuild ms) (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) + buildPackage (msBackgroundBuild ms) (not (msMakeMode ms) && msSingleBuildWithoutLinking ms) + (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoInstall} = do packageInstall' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoClean} = do @@ -163,12 +182,12 @@ constrCont ms pos (Just neg) False = doBuildChain ms neg constrCont ms pos _ _ = doBuildChain ms pos -makePackages :: MakeSettings -> [IDEPackage] -> MakeOp -> WorkspaceAction -makePackages ms targets op = do +makePackages :: MakeSettings -> [IDEPackage] -> MakeOp -> MakeOp -> WorkspaceAction +makePackages ms targets op1 op2 = trace ("makePackages : " ++ show op1 ++ " " ++ show op2) $ do ws <- ask lift $ do prefs' <- readIDE prefs - let plan = constrMakeChain ms ws targets op + let plan = constrMakeChain ms ws targets op1 op2 trace ("makeChain : " ++ show plan) $ doBuildChain ms plan diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -109,18 +109,18 @@ mkActions :: [ActionDescr IDERef] mkActions = [AD "File" "_File" Nothing Nothing (return ()) [] False - ,AD "FileNew" "_New Module" Nothing (Just "gtk-new") + ,AD "FileNew" "_New Module..." Nothing (Just "gtk-new") (packageTry_ $ addModule []) [] False ,AD "FileNewTextFile" "_New Text File" Nothing Nothing fileNew [] False - ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") + ,AD "FileOpen" "_Open..." Nothing (Just "gtk-open") fileOpen [] False - ,AD "RecentFiles" "_Recent Files" Nothing Nothing (return ()) [] False + ,AD "RecentFiles" "Open _Recent" Nothing Nothing (return ()) [] False ,AD "FileRevert" "_Revert" Nothing Nothing fileRevert [] False ,AD "FileSave" "_Save" Nothing (Just "gtk-save") (do fileSave False; return ()) [] False - ,AD "FileSaveAs" "Save _As" Nothing (Just "gtk-save-as") + ,AD "FileSaveAs" "Save _As..." Nothing (Just "gtk-save-as") (do fileSave True; return ()) [] False ,AD "FileSaveAll" "Save A_ll" Nothing Nothing (do fileSaveAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False @@ -179,17 +179,17 @@ (align ':') [] False ,AD "Workspace" "_Workspace" Nothing Nothing (return ()) [] False - ,AD "NewWorkspace" "_New Workspace" Nothing Nothing - workspaceNew [] False - ,AD "OpenWorkspace" "_Open Workspace" Nothing Nothing - workspaceOpen [] False - ,AD "RecentWorkspaces" "_Recent Workspaces" Nothing Nothing (return ()) [] False - ,AD "CloseWorkspace" "_Close Workspace" Nothing Nothing + ,AD "NewWorkspace" "_New..." Nothing Nothing + (workspaceNew >> showWorkspace) [] False + ,AD "OpenWorkspace" "_Open..." Nothing Nothing + (workspaceOpen >> showWorkspace) [] False + ,AD "RecentWorkspaces" "Open _Recent" Nothing Nothing (return ()) [] False + ,AD "CloseWorkspace" "_Close" Nothing Nothing workspaceClose [] False - ,AD "CleanWorkspace" "Cl_ean Workspace" (Just "Cleans all packages") (Just "ide_clean") + ,AD "CleanWorkspace" "Cl_ean" (Just "Cleans all packages") (Just "ide_clean") (workspaceTry_ workspaceClean) [] False - ,AD "MakeWorkspace" "_Make Workspace" (Just "Makes all of this workspace") (Just "ide_configure") + ,AD "MakeWorkspace" "_Make" (Just "Makes all of this workspace") (Just "ide_configure") (workspaceTry_ workspaceMake) [] False ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") nextError [] False @@ -197,36 +197,38 @@ previousError [] False ,AD "Package" "_Package" Nothing Nothing (return ()) [] False - ,AD "NewPackage" "_New Package" Nothing Nothing - (workspaceTry_ workspacePackageNew) [] False + ,AD "NewPackage" "_New..." Nothing Nothing + (showWorkspace >> workspaceTry_ workspacePackageNew) [] False + ,AD "AddPackage" "_Add..." Nothing Nothing + (showWorkspace >> workspaceTry_ workspaceAddPackage) [] False -- ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False - ,AD "EditPackage" "_Edit Package" Nothing Nothing + ,AD "EditPackage" "_Edit" Nothing Nothing (packageTry_ packageEdit) [] False -- ,AD "RemovePackage" "_Close Package" Nothing Nothing -- removePackage [] False ,AD "PackageFlags" "Edit Flags" (Just "Edit the package flags") Nothing (getFlags Nothing >>= \ p -> displayPane p False) [] False - ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") (Just "ide_clean") + ,AD "CleanPackage" "Cl_ean" (Just "Cleans the package") (Just "ide_clean") (packageTry_ packageClean) [] False - ,AD "ConfigPackage" "_Configure Package" (Just "Configures the package") (Just "ide_configure") + ,AD "ConfigPackage" "_Configure" (Just "Configures the package") (Just "ide_configure") (packageTry_ packageConfig) [] False - ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make") + ,AD "BuildPackage" "_Build" (Just "Builds the package") (Just "ide_make") (packageTry_ makePackage) [] False ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing (packageTry_ packageDoc) [] False - ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing + ,AD "CopyPackage" "_Copy" (Just "Copies the package") Nothing (packageTry_ packageCopy) [] False ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") (packageTry_ packageRun) [] False ,AD "ResolveErrors" "Resol_ve Errors" (Just "Resolve 'Hidden package' and 'Not in scope' errors by adding the necessary dependancies or imports") Nothing resolveErrors [] False - ,AD "InstallPackage" "_Install Package" Nothing Nothing + ,AD "InstallPackage" "_Install" Nothing Nothing (packageTry_ packageInstall) [] False - ,AD "RegisterPackage" "_Register Package" Nothing Nothing + ,AD "RegisterPackage" "_Register" Nothing Nothing (packageTry_ packageRegister) [] False - ,AD "TestPackage" "Test Package" Nothing Nothing + ,AD "TestPackage" "Test" Nothing Nothing (packageTry_ packageTest) [] False ,AD "SdistPackage" "Source Dist" Nothing Nothing (packageTry_ packageSdist) [] False @@ -336,7 +338,7 @@ ,AD "ShowLog" "Log" Nothing Nothing showLog [] False ,AD "ShowWorkspace" "Workspace" Nothing Nothing - (getWorkspace Nothing >>= \ p -> displayPane p False) [] False + showWorkspace [] False ,AD "View" "_View" Nothing Nothing (return ()) [] False ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing @@ -407,8 +409,8 @@ ,AD "BackgroundBuildToggled" "_BackgroundBuild" (Just "Build in the background and report errors") (Just "ide_build") backgroundBuildToggled [] True - ,AD "BackgroundLinkToggled" "_BackgroundLink" (Just "Link in the background") (Just "ide_link") - backgroundLinkToggled [] True + ,AD "MakeModeToggled" "_MakeMode" (Just "Make dependend packages") (Just "ide_make") + makeModeToggled [] True ,AD "DebugToggled" "_Debug" (Just "Use GHCi debugger to build and run") (Just "ide_debug") debugToggled [] True ,AD "OpenDocu" "_OpenDocu" (Just "Opens a browser for a search of the selected data") Nothing @@ -450,7 +452,7 @@ fe <- doesFileExist s when fe $ do mi <- menuItemNewWithLabel s - mi `onActivateLeaf` (reflectIDE (workspaceOpenThis True (Just s) >> return ()) ideR) + mi `onActivateLeaf` (reflectIDE (workspaceOpenThis True (Just s) >> showWorkspace) ideR) menuShellAppend recentWorkspacesMenu mi) recentWorkspaces' oldSubmenu <- menuItemGetSubmenu recentWorkspacesItem when (isJust oldSubmenu) $ do @@ -692,7 +694,7 @@ reflectIDE (do setCandyState (fst (sourceCandy prefs)) setBackgroundBuildToggled (backgroundBuild prefs) - setBackgroundLinkToggled (backgroundLink prefs)) ideR + setMakeModeToggled (makeMode prefs)) ideR instrumentSecWindow :: Window -> IDEAction instrumentSecWindow win = do diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Completion --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : @@ -260,7 +260,7 @@ drawWindow False [PointerMotionMask, ButtonReleaseMask] - (Nothing::Maybe DrawWindow) + (Nothing:: Maybe DrawWindow) Nothing time when (status == GrabSuccess) $ liftIO $ do 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 @@ -54,7 +54,6 @@ , KeyString , Prefs(..) -, InstallFlag(..) , LogRefType(..) , LogRef(..) @@ -307,7 +306,7 @@ , ipdModules :: Set ModuleName , ipdMain :: [FilePath] , ipdExtraSrcs :: Set FilePath -, ipdSrcDirs :: [FilePath] +, ipdSrcDirs :: [FilePath] , ipdExtensions :: [Extension] , ipdConfigFlags :: [String] , ipdBuildFlags :: [String] @@ -395,9 +394,10 @@ , completeRestricted :: Bool , saveAllBeforeBuild :: Bool , backgroundBuild :: Bool - , backgroundLink :: Bool + , makeMode :: Bool + , singleBuildWithoutLinking :: Bool + , dontInstallLast :: Bool , printEvldWithShow :: Bool - , autoInstall :: InstallFlag , breakOnException :: Bool , breakOnError :: Bool , printBindResult :: Bool @@ -413,9 +413,6 @@ data SearchHint = Forward | Backward | Insert | Delete | Initial deriving (Eq) - -data InstallFlag = InstallAlways | InstallLibs | InstallNo - deriving(Eq,Show, Read, Enum, Bounded) instance Ord Modifier where compare a b = compare (fromEnum a) (fromEnum b) diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -68,12 +68,8 @@ import Text.Regex.TDFA.String (compile) import Data.List (find, isPrefixOf) import Data.Array (bounds, (!), inRange) -import IDE.Utils.Tool (runTool) -import Control.Concurrent (forkIO) -import IDE.Pane.Grep -import IDE.Package (getPackageDescriptionAndPath) -import IDE.Workspaces (packageTry_) -import System.FilePath (dropFileName) +import IDE.Pane.Grep (grepWorkspace) +import IDE.Workspaces (workspaceTry_, packageTry_) data FindState = FindState { entryStr :: String @@ -401,17 +397,7 @@ wrapAround <- liftIO $ getWrapAround fb regex <- liftIO $ getRegex fb let (regexString, _) = regexStringAndMatchIndex entireWord regex search - mbPD <- lift getPackageDescriptionAndPath - lift $ case mbPD of - Nothing -> ideMessage Normal "No package description" - Just (pd,cabalPath) -> do - let srcPaths = ipdSrcDirs package - let dir = dropFileName (cabalPath) - liftIO $ forkIO $ do - (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"]) - ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ srcPaths) (Just dir) - reflectIDE (setGrepResults output) ideR - return () + lift $ workspaceTry_ $ grepWorkspace regexString caseSensitive matchFunc :: ListStore String -> String -> TreeIter -> IO Bool matchFunc model str iter = do diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.ImportTool --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : Jutaro diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -292,7 +292,7 @@ reflectIDE (do setCandyState (fst (sourceCandy startupPrefs)) setBackgroundBuildToggled (backgroundBuild startupPrefs) - setBackgroundLinkToggled (backgroundLink startupPrefs)) ideR + setMakeModeToggled (makeMode startupPrefs)) ideR let (x,y) = defaultSize startupPrefs windowSetDefaultSize win x y (tbv,fbv) <- reflectIDE (do diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.NotebookFlipper --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -37,12 +37,13 @@ , packageOpenDoc , getPackageDescriptionAndPath +, getEmptyModuleTemplate , getModuleTemplate , addModuleToPackageDescr , delModuleFromPackageDescr , backgroundBuildToggled -, backgroundLinkToggled +, makeModeToggled , debugStart , printBindResultFlag @@ -198,14 +199,14 @@ exchange p | ipdCabalFile p == file = ideP | otherwise = p -runCabalBuild :: Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction -runCabalBuild backgroundBuild package shallConfigure continuation = do +runCabalBuild :: Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction +runCabalBuild backgroundBuild withoutLinking package shallConfigure continuation = do prefs <- readIDE prefs let dir = dropFileName (ipdCabalFile package) let args = (["build"] ++ - if ((not backgroundBuild) || (backgroundLink prefs)) - then [] - else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"] + if backgroundBuild && withoutLinking + then ["--with-ld=false"] + else [] ++ ipdBuildFlags package) runExternalTool "Building" "cabal" args (Just dir) $ \output -> do logOutputForBuild package backgroundBuild output @@ -213,7 +214,7 @@ if shallConfigure && isConfigError output then packageConfig' package (\ b -> - when b $ runCabalBuild backgroundBuild package False continuation) + when b $ runCabalBuild backgroundBuild withoutLinking package False continuation) else do continuation (last output == ToolExit ExitSuccess) return () @@ -226,8 +227,8 @@ str1 = "Run the 'configure' command first" str2 = "please re-configure" -buildPackage :: Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction -buildPackage backgroundBuild package continuation = catchIDE (do +buildPackage :: Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction +buildPackage backgroundBuild withoutLinking package continuation = catchIDE (do ideR <- ask prefs <- readIDE prefs maybeDebug <- readIDE debugState @@ -239,10 +240,13 @@ interruptBuild when (not backgroundBuild) $ liftIO $ do timeoutAddFull (do - reflectIDE (do buildPackage backgroundBuild package continuation; return False) ideR + reflectIDE (do + buildPackage backgroundBuild withoutLinking + package continuation + return False) ideR return False) priorityDefaultIdle 1000 return () - else runCabalBuild backgroundBuild package True continuation + else runCabalBuild backgroundBuild withoutLinking package True continuation Just debug@(_, ghci) -> do -- TODO check debug package matches active package ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) @@ -427,18 +431,25 @@ reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR return Nothing)) -getModuleTemplate :: PackageDescription -> String -> IO String -getModuleTemplate pd modName = catch (do +getEmptyModuleTemplate :: PackageDescription -> String -> IO String +getEmptyModuleTemplate pd modName = getModuleTemplate pd modName "" "" + +getModuleTemplate :: PackageDescription -> String -> String -> String -> IO String +getModuleTemplate pd modName exports body = catch (do dataDir <- getDataDir filePath <- getConfigFilePathForLoad standardModuleTemplateFilename Nothing dataDir template <- UTF8.readFile filePath return (foldl' (\ a (from, to) -> replace from to a) template - [("@License@", (show . license) pd), ("@Maintainer@", maintainer pd), - ("@Stability@",stability pd), ("@Portability@",""), - ("@Copyright@", copyright pd),("@ModuleName@", modName)])) + [ ("@License@" , (show . license) pd) + , ("@Maintainer@" , maintainer pd) + , ("@Stability@" , stability pd) + , ("@Portability@" , "") + , ("@Copyright@" , copyright pd) + , ("@ModuleName@" , modName) + , ("@ModuleExports@", exports) + , ("@ModuleBody@" , body)])) (\ (e :: SomeException) -> sysMessage Normal ("Couldn't read template file: " ++ show e) >> return "") - addModuleToPackageDescr :: ModuleName -> Bool -> PackageAction addModuleToPackageDescr moduleName isExposed = do p <- ask @@ -514,10 +525,10 @@ toggled <- getBackgroundBuildToggled modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundBuild= toggled}}) -backgroundLinkToggled :: IDEAction -backgroundLinkToggled = do - toggled <- getBackgroundLinkToggled - modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundLink= toggled}}) +makeModeToggled :: IDEAction +makeModeToggled = do + toggled <- getMakeModeToggled + modifyIDE_ (\ide -> ide{prefs = (prefs ide){makeMode= toggled}}) -- --------------------------------------------------------------------- -- | * Debug code that needs to use the package @@ -576,7 +587,7 @@ -- Lets build to make sure the binaries are up to date mbPackage <- readIDE activePack case mbPackage of - Just package -> runCabalBuild True package True (\ _ -> return ()) + Just package -> runCabalBuild True True package True (\ _ -> return ()) Nothing -> return ()) ideRef return () _ -> do diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs --- a/src/IDE/Pane/Breakpoints.hs +++ b/src/IDE/Pane/Breakpoints.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Breakpoints --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs --- a/src/IDE/Pane/Errors.hs +++ b/src/IDE/Pane/Errors.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Errors --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs --- a/src/IDE/Pane/Grep.hs +++ b/src/IDE/Pane/Grep.hs @@ -16,7 +16,7 @@ module IDE.Pane.Grep ( IDEGrep(..) -, setGrepResults +, grepWorkspace , GrepState(..) , getGrep ) where @@ -29,25 +29,35 @@ import Control.Monad.Reader import Data.Typeable import IDE.Core.State -import IDE.Utils.Tool (ToolOutput(..)) -import Control.Concurrent (forkIO) +import IDE.Utils.Tool (runTool, ToolOutput(..)) +import Control.Concurrent + (newEmptyMVar, isEmptyMVar, takeMVar, putMVar, MVar, forkIO) import IDE.LogRef (logOutput) import IDE.Pane.SourceBuffer (goToSourceDefinition) +import Control.Applicative ((<$>)) +import System.FilePath ((), dropFileName) +import System.Exit (ExitCode(..)) data GrepRecord = GrepRecord { - file :: FilePath -, line :: Int -, context :: String -} + file :: FilePath + , line :: Int + , context :: String + , parDir :: Maybe FilePath + } +isDir GrepRecord{parDir = Nothing} = True +isDir otherwies = False + -- | A grep pane description -- data IDEGrep = IDEGrep { scrolledView :: ScrolledWindow , treeView :: TreeView -, grepStore :: ListStore GrepRecord +, grepStore :: TreeStore GrepRecord +, waitingGrep :: MVar Bool +, activeGrep :: MVar Bool } deriving Typeable data GrepState = GrepState @@ -67,9 +77,9 @@ nb <- getNotebook pp buildPane pp nb builder builder pp nb windows = reifyIDE $ \ ideR -> do - listStore <- listStoreNew [] + grepStore <- treeStoreNew [] treeView <- treeViewNew - treeViewSetModel treeView listStore + treeViewSetModel treeView grepStore renderer1 <- cellRendererTextNew renderer10 <- cellRendererPixbufNew @@ -81,7 +91,7 @@ treeViewAppendColumn treeView col1 cellLayoutPackStart col1 renderer10 False cellLayoutPackStart col1 renderer1 True - cellLayoutSetAttributes col1 renderer1 listStore + cellLayoutSetAttributes col1 renderer1 grepStore $ \row -> [ cellText := file row] renderer2 <- cellRendererTextNew @@ -92,7 +102,7 @@ treeViewColumnSetReorderable col2 True treeViewAppendColumn treeView col2 cellLayoutPackStart col2 renderer2 True - cellLayoutSetAttributes col2 renderer2 listStore + cellLayoutSetAttributes col2 renderer2 grepStore $ \row -> [ cellText := show $ line row] renderer3 <- cellRendererTextNew @@ -105,7 +115,7 @@ treeViewAppendColumn treeView col3 cellLayoutPackStart col3 renderer30 False cellLayoutPackStart col3 renderer3 True - cellLayoutSetAttributes col3 renderer3 listStore + cellLayoutSetAttributes col3 renderer3 grepStore $ \row -> [ cellText := context row] @@ -113,20 +123,24 @@ sel <- treeViewGetSelection treeView treeSelectionSetMode sel SelectionSingle - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledView <- scrolledWindowNew Nothing Nothing + containerAdd scrolledView treeView + scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic - let grep = IDEGrep sw treeView listStore + waitingGrep <- newEmptyMVar + activeGrep <- newEmptyMVar + let grep = IDEGrep {..} cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive grep) ideR ; return True) sel `onSelectionChanged` do - sel <- getSelectionGrepRecord treeView listStore + sel <- getSelectionGrepRecord treeView grepStore case sel of Just record -> reflectIDE (do - goToSourceDefinition (file record) - $ Just $ Location (line record) 0 (line record) 0) ideR + case record of + GrepRecord {file=f, line=l, parDir=Just pp} -> + goToSourceDefinition (pp f) $ Just $ Location l 0 l 0 + _ -> return ()) ideR Nothing -> return () return (Just grep,[ConnectC cid1]) @@ -142,6 +156,7 @@ line <- int char ':' context <- many anyChar + let parDir = Nothing return $ GrepRecord {..} "grepLineParser") @@ -155,43 +170,98 @@ int = fmap fromInteger $ P.integer lexer getSelectionGrepRecord :: TreeView - -> ListStore GrepRecord + -> TreeStore GrepRecord -> IO (Maybe GrepRecord) -getSelectionGrepRecord treeView listStore = do +getSelectionGrepRecord treeView grepStore = do treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows treeSelection case paths of - [a]:r -> do - size <- listStoreGetSize listStore - if a < size - then fmap Just $ listStoreGetValue listStore a - else return Nothing - _ -> return Nothing + p:_ -> Just <$> treeStoreGetValue grepStore p + _ -> return Nothing -setGrepResults :: [ToolOutput] -> IDEAction -setGrepResults output = do +grepWorkspace :: String -> Bool -> WorkspaceAction +grepWorkspace "" caseSensitive = return () +grepWorkspace regexString caseSensitive = do + ws <- ask + maybeActive <- lift $ readIDE activePack + let packages = case maybeActive of + Just active -> active : (filter (/= active) $ wsPackages ws) + Nothing -> wsPackages ws + lift $ grepDirectories regexString caseSensitive $ + map (\p -> (dropFileName (ipdCabalFile p), ipdSrcDirs p)) $ packages + +grepDirectories :: String -> Bool -> [(FilePath, [FilePath])] -> IDEAction +grepDirectories regexString caseSensitive dirs = do grep <- getGrep Nothing + let store = grepStore grep ideRef <- ask liftIO $ do - let (displayed, dropped) = splitAt 10000 output bringPaneToFront grep forkIO $ do - let errors = filter (isNothing . process) output + putMVar (waitingGrep grep) True + putMVar (activeGrep grep) True + takeMVar (waitingGrep grep) + + postGUIAsync $ treeStoreClear store + + totalFound <- foldM (\a (dir, subDirs) -> do + nooneWaiting <- isEmptyMVar (waitingGrep grep) + found <- if nooneWaiting + then do + (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"]) + ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ subDirs) (Just dir) + reflectIDE (setGrepResults dir output) ideRef + else return 0 + return $ a + found) 0 dirs + + nooneWaiting <- isEmptyMVar (waitingGrep grep) + when nooneWaiting $ do + nDir <- postGUISync $ treeModelIterNChildren store Nothing + postGUIAsync $ treeStoreInsert store [] nDir $ + GrepRecord "Search Complete" totalFound "" Nothing + + takeMVar (activeGrep grep) >> return () + return () + +setGrepResults :: FilePath -> [ToolOutput] -> IDEM Int +setGrepResults dir output = do + grep <- getGrep Nothing + let store = grepStore grep + view = treeView grep + ideRef <- ask + liftIO $ do + let (displayed, dropped) = splitAt 5000 output + forkIO $ do + let errors = filter isError output ++ if null dropped then [] else [ToolError $ "Dropped " ++ show (length dropped) ++ " search results"] - unless (null errors) $ reflectIDE (logOutput errors) ideRef + unless (null errors) $ postGUISync $ reflectIDE (logOutput errors) ideRef return () - postGUIAsync $ listStoreClear (grepStore grep) - forM_ (catMaybes (map process displayed)) $ \record -> do - postGUIAsync $ do - listStoreAppend (grepStore grep) record - return () + case catMaybes (map (process dir) displayed) of + [] -> return 0 + results -> do + nDir <- postGUISync $ treeModelIterNChildren store Nothing + postGUIAsync $ treeStoreInsert store [] nDir $ GrepRecord dir 0 "" Nothing + forM_ (zip results [0..]) $ \(record, n) -> do + nooneWaiting <- isEmptyMVar (waitingGrep grep) + when nooneWaiting $ postGUIAsync $ do + treeStoreInsert store [nDir] n record + treeStoreChange store [nDir] (\r -> r{ line = n+1 }) >> return () + when (nDir == 0 && n == 0) $ + treeViewExpandAll view + return $ length results where - process (ToolOutput line) = + process pp (ToolOutput line) = case parse grepLineParser "" line of - Right record -> Just record + Right record -> Just record{parDir = Just pp} _ -> Nothing - process _ = Nothing + process _ _ = Nothing + + isError (ToolExit ExitSuccess) = False + isError (ToolExit (ExitFailure 1)) = False + isError o = isNothing (process "" o) + + 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 @@ -46,7 +46,7 @@ import Distribution.Text (simpleParse,display) import Data.Typeable (Typeable(..)) import Control.Exception (SomeException(..),catch) -import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getModuleTemplate,getPackageDescriptionAndPath) +import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getEmptyModuleTemplate,getPackageDescriptionAndPath) import Distribution.PackageDescription (allBuildInfo,hsSourceDirs) import System.FilePath (takeBaseName, (),dropFileName) import System.Directory (doesFileExist,createDirectoryIfMissing, removeFile) @@ -1096,7 +1096,7 @@ addModuleToPackageDescr moduleName isExposed packageConfig else do - template <- liftIO $ getModuleTemplate pd modPath + template <- liftIO $ getEmptyModuleTemplate pd modPath liftIO $ UTF8.writeFile target template addModuleToPackageDescr moduleName isExposed packageConfig 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 @@ -139,29 +139,29 @@ in libConds || exeConds -packageNew' :: Maybe FilePath -> (FilePath -> IDEAction) -> IDEAction +packageNew' :: Maybe FilePath -> (Bool -> FilePath -> IDEAction) -> IDEAction packageNew' mbDir activateAction = do windows <- getWindows mbDirName <- liftIO $ choosePackageDir (head windows) mbDir case mbDirName of Nothing -> return () Just dirName -> do - cfn <- liftIO $ cabalFileName dirName - continue <- do - if isJust cfn - then do - window <- getMainWindow - liftIO $ do - md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel - $ "There is already a .cabal file in this directory." - dialogAddButton md "_Continue Anyway" (ResponseUser 1) - dialogSetDefaultResponse md (ResponseUser 1) - set md [ windowWindowPosition := WinPosCenterOnParent ] - rid <- dialogRun md - widgetDestroy md - return $ rid == ResponseUser 1 - else return True - when continue $ do + mbCabalFile <- liftIO $ cabalFileName dirName + case mbCabalFile of + Just cfn -> do + window <- getMainWindow + add <- liftIO $ do + md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel + $ "There is already file " ++ takeFileName cfn ++ " in this directory. " + ++ "Would you like to add this package to the workspace?" + dialogAddButton md "_Add Package" (ResponseUser 1) + dialogSetDefaultResponse md (ResponseUser 1) + set md [ windowWindowPosition := WinPosCenterOnParent ] + rid <- dialogRun md + widgetDestroy md + return $ rid == ResponseUser 1 + when add $ activateAction False cfn + Nothing -> do modules <- liftIO $ do b1 <- doesFileExist (dirName "Setup.hs") b2 <- doesFileExist (dirName "Setup.lhs") @@ -181,7 +181,7 @@ exeName = (takeBaseName dirName), modulePath = "Main.hs", buildInfo = emptyBuildInfo {hsSourceDirs = ["src"]}}] - } dirName modules activateAction + } dirName modules (activateAction True) return () standardSetup = "#!/usr/bin/runhaskell \n" 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 @@ -603,24 +603,31 @@ boolEditor (\i -> return ()) , mkFieldPP - (paraName <<<- ParaName "Include linking in background builds" $ emptyParams) + (paraName <<<- ParaName "Make mode" $ emptyParams) (PP.text . show) boolParser - backgroundLink - (\b a -> a{backgroundLink = b}) + makeMode + (\b a -> a{makeMode = b}) + (boolEditor2 "Single mode") + (\i -> return ()) + + , mkFieldPP + (paraName <<<- ParaName "Single build without linking" $ emptyParams) + (PP.text . show) + boolParser + singleBuildWithoutLinking + (\b a -> a{singleBuildWithoutLinking = b}) boolEditor (\i -> return ()) , mkFieldPP - (paraName <<<- ParaName "Auto install packages" $ - paraShadow <<<- ParaShadow ShadowIn $emptyParams) + (paraName <<<- ParaName "Don't install last package" $ emptyParams) (PP.text . show) - readParser - autoInstall - (\b a -> a{autoInstall = b}) - (enumEditor ["Install always after a successful build", - "Install if it's a library with dependent packages in the workspace", - "Never install"]) + boolParser + dontInstallLast + (\b a -> a{dontInstallLast = b}) + boolEditor (\i -> return ()) + ]), ("Debug", VFDPP emptyParams [ mkFieldPP @@ -735,13 +742,9 @@ , completeRestricted = False , saveAllBeforeBuild = True , backgroundBuild = True - , backgroundLink = -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - False -#else - True -#endif - , autoInstall = InstallLibs + , makeMode = True + , singleBuildWithoutLinking = False + , dontInstallLast = False , printEvldWithShow = True , breakOnException = True , breakOnError = True 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 @@ -423,7 +423,8 @@ (False,_) -> Nothing (True,v) -> Just v setIndentWidth sv $ tabWidth prefs - setTabWidth sv $ tabWidth prefs + setTabWidth sv $ 8 -- GHC treats tabs as 8 we should display them that way + drawTabs sv setStyle buffer $ case sourceStyle prefs of (False,_) -> Nothing (True,v) -> Just v diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs --- a/src/IDE/Pane/Trace.hs +++ b/src/IDE/Pane/Trace.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Trace --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs --- a/src/IDE/Pane/Variables.hs +++ b/src/IDE/Pane/Variables.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Variables --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs --- a/src/IDE/Pane/Workspace.hs +++ b/src/IDE/Pane/Workspace.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Workspace --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -18,6 +18,7 @@ , IDEWorkspace , updateWorkspace , getWorkspace +, showWorkspace ) where import Graphics.UI.Gtk hiding (get) @@ -122,6 +123,11 @@ getWorkspace :: Maybe PanePath -> IDEM IDEWorkspace getWorkspace Nothing = forceGetPane (Right "*Workspace") getWorkspace (Just pp) = forceGetPane (Left pp) + +showWorkspace :: IDEAction +showWorkspace = do + l <- getWorkspace Nothing + displayPane l False getSelectionTree :: TreeView -> ListStore (Bool, IDEPackage) diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs --- a/src/IDE/PaneGroups.hs +++ b/src/IDE/PaneGroups.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.PaneGroups --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Statusbar.hs b/src/IDE/Statusbar.hs --- a/src/IDE/Statusbar.hs +++ b/src/IDE/Statusbar.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Statusbar --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs --- a/src/IDE/TextEditor.hs +++ b/src/IDE/TextEditor.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.TextEditor --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -67,6 +67,7 @@ -- View , bufferToWindowCoords +, drawTabs , getBuffer , getDrawWindow , getIterLocation @@ -570,6 +571,12 @@ bufferToWindowCoords (YiEditorView v) point = return point -- TODO #endif +drawTabs :: EditorView -> IDEM () +drawTabs (GtkEditorView sv) = liftIO $ Gtk.sourceViewSetDrawSpaces sv Gtk.SourceDrawSpacesTab +#ifdef LEKSAH_WITH_YI +drawTabs (YiEditorView _) = return () -- TODO +#endif + getBuffer :: EditorView -> IDEM EditorBuffer getBuffer (GtkEditorView sv) = liftIO $ fmap (GtkEditorBuffer . Gtk.castToSourceBuffer) $ sv `Gtk.get` Gtk.textViewBuffer #ifdef LEKSAH_WITH_YI @@ -1089,7 +1096,8 @@ id2 <- sv `Gtk.onMoveCursor` \_ _ _ -> reflectIDE cancel ideR #endif id3 <- sv `Gtk.onButtonPress` \_ -> reflectIDE cancel ideR >> return False - return [ConnectC id1] + id4 <- sv `Gtk.onFocusOut` \_ -> reflectIDE cancel ideR >> return False + return [ConnectC id1, ConnectC id2, ConnectC id3, ConnectC id4] #ifdef LEKSAH_WITH_YI onCompletion (YiEditorView v) start cancel = return [] -- TODO #endif diff --git a/src/IDE/Utils/GUIUtils.hs b/src/IDE/Utils/GUIUtils.hs --- a/src/IDE/Utils/GUIUtils.hs +++ b/src/IDE/Utils/GUIUtils.hs @@ -23,8 +23,8 @@ , getBackgroundBuildToggled , setBackgroundBuildToggled -, getBackgroundLinkToggled -, setBackgroundLinkToggled +, getMakeModeToggled +, setMakeModeToggled , getDebugToggled , setDebugToggled @@ -170,14 +170,14 @@ ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction liftIO $ toggleActionSetActive ui b -getBackgroundLinkToggled :: PaneMonad alpha => alpha (Bool) -getBackgroundLinkToggled = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction +getMakeModeToggled :: PaneMonad alpha => alpha (Bool) +getMakeModeToggled = do + ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" castToToggleAction liftIO $ toggleActionGetActive ui -setBackgroundLinkToggled :: PaneMonad alpha => Bool -> alpha () -setBackgroundLinkToggled b = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction +setMakeModeToggled :: PaneMonad alpha => Bool -> alpha () +setMakeModeToggled b = do + ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" castToToggleAction liftIO $ toggleActionSetActive ui b getDebugToggled :: PaneMonad alpha => alpha (Bool) @@ -191,8 +191,8 @@ liftIO $ toggleActionSetActive ui b getRecentFiles , getRecentWorkspaces :: IDEM MenuItem -getRecentFiles = getMenuItem "ui/menubar/_File/_Recent Files" -getRecentWorkspaces = getMenuItem "ui/menubar/_Workspace/_Recent Workspaces" +getRecentFiles = getMenuItem "ui/menubar/_File/Open _Recent" +getRecentWorkspaces = getMenuItem "ui/menubar/_Workspace/Open _Recent" -- (toolbar) diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs --- a/src/IDE/Utils/ServerConnection.hs +++ b/src/IDE/Utils/ServerConnection.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.ServerConnection --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Workspace --- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -278,11 +278,12 @@ workspacePackageNew = do ws <- ask let path = dropFileName (wsFile ws) - lift $ packageNew' (Just path) (\fp -> do + lift $ packageNew' (Just path) (\isNew fp -> do window <- getMainWindow workspaceTry_ $ workspaceAddPackage' fp >> return () - mbPack <- idePackageFromPath fp - constructAndOpenMainModule mbPack + when isNew $ do + mbPack <- idePackageFromPath fp + constructAndOpenMainModule mbPack triggerEventIDE UpdateWorkspaceInfo >> return ()) constructAndOpenMainModule :: Maybe IDEPackage -> IDEAction @@ -296,15 +297,17 @@ liftIO $ createDirectoryIfMissing True path alreadyExists <- liftIO $ doesFileExist (path target) if alreadyExists - then ideMessage Normal "Main file already exists" + then do + ideMessage Normal "Main file already exists" + fileOpenThis (path target) else do template <- liftIO $ getModuleTemplate pd (dropExtension target) + " main" "main = putStrLn \"Hello World!\"" liftIO $ UTF8.writeFile (path target) template fileOpenThis (path target) Nothing -> ideMessage Normal "No package description" _ -> return () - workspaceAddPackage :: WorkspaceAction workspaceAddPackage = do ws <- ask @@ -313,7 +316,9 @@ mbFilePath <- liftIO $ choosePackageFile window (Just path) case mbFilePath of Nothing -> return () - Just fp -> workspaceAddPackage' fp >> return () + Just fp -> do + workspaceAddPackage' fp >> return () + lift $ triggerEventIDE UpdateWorkspaceInfo >> return () workspaceAddPackage' :: FilePath -> WorkspaceM (Maybe IDEPackage) workspaceAddPackage' fp = do @@ -509,26 +514,21 @@ workspaceClean :: WorkspaceAction workspaceClean = do ws <- ask - let settings = MakeSettings { - msInstallMode = InstallNo, - msIsSingleMake = False, - msSaveAllBeforeBuild = False, - msBackgroundBuild = False, - msLinkingInBB = False} - makePackages settings (wsPackages ws) MoClean + settings <- lift $ do + prefs' <- readIDE prefs + return (defaultMakeSettings prefs') + makePackages settings (wsPackages ws) MoClean MoClean workspaceMake :: WorkspaceAction workspaceMake = do ws <- ask settings <- lift $ do prefs' <- readIDE prefs - return (MakeSettings { - msInstallMode = autoInstall prefs', - msIsSingleMake = False, - msSaveAllBeforeBuild = saveAllBeforeBuild prefs', - msBackgroundBuild = False, - msLinkingInBB = False}) + return ((defaultMakeSettings prefs'){ + msMakeMode = True, + msBackgroundBuild = False}) makePackages settings (wsPackages ws) (MoComposed [MoConfigure,MoBuild,MoInstall]) + (MoComposed [MoConfigure,MoBuild,MoInstall]) backgroundMake :: IDEAction backgroundMake = catchIDE (do @@ -543,13 +543,13 @@ else return [] let isModified = not (null modifiedPacks) when isModified $ do - let settings = MakeSettings { - msInstallMode = autoInstall prefs, - msIsSingleMake = False, - msSaveAllBeforeBuild = saveAllBeforeBuild prefs, - msBackgroundBuild = True, - msLinkingInBB = True} - workspaceTryQuiet_ $ makePackages settings modifiedPacks (MoComposed [MoBuild,MoInstall]) + let settings = defaultMakeSettings prefs + if msSingleBuildWithoutLinking settings && not (msMakeMode settings) + then workspaceTryQuiet_ $ + makePackages settings modifiedPacks MoBuild (MoComposed []) + else workspaceTryQuiet_ $ + makePackages settings modifiedPacks (MoComposed [MoBuild,MoInstall]) + (MoComposed [MoConfigure,MoBuild,MoInstall]) ) (\(e :: SomeException) -> sysMessage Normal (show e)) @@ -559,12 +559,16 @@ (mbWs,settings) <- lift $ do prefs' <- readIDE prefs ws <- readIDE workspace - return (ws,MakeSettings { - msInstallMode = autoInstall prefs', - msIsSingleMake = False, - msSaveAllBeforeBuild = saveAllBeforeBuild prefs', - msBackgroundBuild = False, - msLinkingInBB = False}) + let settings = (defaultMakeSettings prefs'){msBackgroundBuild = False} + return (ws,settings) case mbWs of Nothing -> sysMessage Normal "No workspace for build." - Just ws -> lift $ runWorkspace (makePackages settings [p] (MoComposed [MoBuild,MoInstall])) ws + Just ws -> lift $ + if msSingleBuildWithoutLinking settings && not (msMakeMode settings) + then runWorkspace + (makePackages settings [p] MoBuild (MoComposed [])) ws + else runWorkspace + (makePackages settings [p] + (MoComposed [MoBuild,MoInstall]) + (MoComposed [MoConfigure,MoBuild,MoInstall])) ws +