diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,5 +1,5 @@ name: leksah -version: 0.12.1.2 +version: 0.12.1.3 cabal-version: >=1.10 build-type: Simple license: GPL @@ -200,7 +200,7 @@ QuickCheck >=2.4.2 && <2.5 else hs-source-dirs: main - build-depends: leksah ==0.12.1.2, base >=4.0.0.0 && <= 5 + build-depends: leksah ==0.12.1.3, base >=4.0.0.0 && <= 5 default-language: Haskell98 main-is: Main.hs @@ -215,7 +215,7 @@ hs-source-dirs: tests main-is: Tests.hs build-depends: base >= 4.0.0.0 && <4.6, Cabal >=1.6.0.1 && <1.15, QuickCheck >=2.4.2 && <2.5, - leksah ==0.12.1.2 + leksah ==0.12.1.3 diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -115,7 +115,7 @@ mkActions = [AD "File" "_File" Nothing Nothing (return ()) [] False ,AD "FileNew" "_New Module..." Nothing (Just "gtk-new") - (packageTry_ $ addModule []) [] False + (packageTry $ addModule []) [] False ,AD "FileNewTextFile" "_New Text File" Nothing Nothing fileNew [] False ,AD "FileOpen" "_Open..." Nothing (Just "gtk-open") @@ -193,9 +193,9 @@ workspaceClose [] False ,AD "CleanWorkspace" "Cl_ean" (Just "Cleans all packages") (Just "ide_clean") - (workspaceTry_ workspaceClean) [] False + (workspaceTry workspaceClean) [] False ,AD "MakeWorkspace" "_Make" (Just "Makes all of this workspace") (Just "ide_configure") - (workspaceTry_ workspaceMake) [] False + (workspaceTry workspaceMake) [] False ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") nextError [] False ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev") @@ -203,46 +203,46 @@ ,AD "Package" "_Package" Nothing Nothing (return ()) [] False ,AD "NewPackage" "_New..." Nothing Nothing - (showWorkspace >> workspaceTry_ workspacePackageNew) [] False + (showWorkspace >> workspaceTry workspacePackageNew) [] False ,AD "AddPackage" "_Add..." Nothing Nothing - (showWorkspace >> workspaceTry_ workspaceAddPackage) [] False + (showWorkspace >> workspaceTry workspaceAddPackage) [] False -- ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False ,AD "EditPackage" "_Edit" Nothing Nothing - (packageTry_ packageEdit) [] False + (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" (Just "Cleans the package") (Just "ide_clean") - (packageTry_ packageClean) [] False + (packageTry packageClean) [] False ,AD "ConfigPackage" "_Configure" (Just "Configures the package") (Just "ide_configure") - (packageTry_ packageConfig) [] False + (packageTry packageConfig) [] False ,AD "BuildPackage" "_Build" (Just "Builds the package") (Just "ide_make") - (packageTry_ makePackage) [] False + (packageTry makePackage) [] False ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing - (packageTry_ packageDoc) [] False + (packageTry packageDoc) [] False ,AD "CopyPackage" "_Copy" (Just "Copies the package") Nothing - (packageTry_ packageCopy) [] False + (packageTry packageCopy) [] False ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") - (packageTry_ packageRun) [] False + (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 "InstallDependenciesPackage" "_Install Dependencies" (Just "Install the package's dependencies from the hackage server") Nothing - (packageTry_ packageInstallDependencies) [] False + (packageTry packageInstallDependencies) [] False ,AD "RegisterPackage" "_Register" Nothing Nothing - (packageTry_ packageRegister) [] False + (packageTry packageRegister) [] False ,AD "TestPackage" "Test" Nothing Nothing - (packageTry_ packageTest) [] False + (packageTry packageTest) [] False ,AD "SdistPackage" "Source Dist" Nothing Nothing - (packageTry_ packageSdist) [] False + (packageTry packageSdist) [] False ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing - (packageTry_ packageOpenDoc) [] False + (packageTry packageOpenDoc) [] False ,AD "Debug" "_Debug" Nothing Nothing (return ()) [] False ,AD "StartDebugger" "_Start Debugger" (Just "Starts using the GHCi debugger for build and run") Nothing - (packageTry_ debugStart) [] False + (packageTry debugStart) [] False ,AD "QuitDebugger" "_Quit Debugger" (Just "Quit the GHCi debugger if it is running") Nothing debugQuit [] False ,AD "ExecuteSelection" "_Execute Selection" (Just "Sends the selected text to the debugger") Nothing diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -77,10 +77,10 @@ import IDE.Pane.Log (appendLog) import Data.List (isSuffixOf) import IDE.Utils.GUIUtils (getDebugToggled) -import IDE.Package (debugStart, executeDebugCommand, tryDebug_, printBindResultFlag, +import IDE.Package (debugStart, executeDebugCommand, tryDebug, printBindResultFlag, breakOnErrorFlag, breakOnExceptionFlag, printEvldWithShowFlag) import IDE.Utils.Tool (ToolOutput(..), toolProcess, interruptProcessGroupOf) -import IDE.Workspaces (packageTry_) +import IDE.Workspaces (packageTry) import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL import Control.Monad.Trans.Class (MonadTrans(..)) @@ -105,7 +105,7 @@ toggled <- getDebugToggled maybeDebug <- readIDE debugState case (toggled, maybeDebug) of - (True, Nothing) -> packageTry_ $ debugStart + (True, Nothing) -> packageTry $ debugStart (False, Just _) -> debugQuit _ -> return () @@ -120,7 +120,7 @@ debugExecuteSelection = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do debugSetLiberalScope debugCommand text logOutput Nothing -> ideMessage Normal "Please select some text in the editor to execute" @@ -129,7 +129,7 @@ debugExecuteAndShowSelection = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do debugSetLiberalScope debugCommand text $ do (out, _) <- EL.zip (EL.fold buildOutputString "") logOutput @@ -152,27 +152,27 @@ case mbPackage of Nothing -> return () Just p -> let packageNames = map (display . modu . mdModuleId) (pdModules p) - in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module + " packageNames) + in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module " packageNames) logOutput debugAbandon :: IDEAction -debugAbandon = packageTry_ $ tryDebug_ $ debugCommand ":abandon" logOutput +debugAbandon = packageTry $ tryDebug $ debugCommand ":abandon" logOutput debugBack :: IDEAction -debugBack = packageTry_ $ do +debugBack = packageTry $ do currentHist' <- lift $ readIDE currentHist rootPath <- lift activeProjectDir lift $ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0}) - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":back" (logOutputForHistoricContext debugPackage) debugForward :: IDEAction -debugForward = packageTry_ $ do +debugForward = packageTry $ do currentHist' <- lift $ readIDE currentHist rootPath <- lift activeProjectDir lift $ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1}) - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":forward" (logOutputForHistoricContext debugPackage) @@ -184,20 +184,20 @@ Nothing -> return () debugContinue :: IDEAction -debugContinue = packageTry_ $ do +debugContinue = packageTry $ do rootPath <- lift $ activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":continue" (logOutputForLiveContext debugPackage) debugDeleteAllBreakpoints :: IDEAction debugDeleteAllBreakpoints = do - packageTry_ $ tryDebug_ $ debugCommand ":delete *" logOutput + packageTry $ tryDebug $ debugCommand ":delete *" logOutput setBreakpointList [] debugDeleteBreakpoint :: String -> LogRef -> IDEAction debugDeleteBreakpoint indexString lr = do - packageTry_ $ tryDebug_ $ debugCommand (":delete " ++ indexString) logOutput + packageTry $ tryDebug $ debugCommand (":delete " ++ indexString) logOutput bl <- readIDE breakpointRefs setBreakpointList $ filter (/= lr) bl ideR <- ask @@ -207,30 +207,30 @@ debugForce = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ debugCommand (":force " ++ text) logOutput + Just text -> packageTry $ tryDebug $ debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an expression in the editor" debugHistory :: IDEAction -debugHistory = packageTry_ $ tryDebug_ $ debugCommand ":history" logOutput +debugHistory = packageTry $ tryDebug $ debugCommand ":history" logOutput debugPrint :: IDEAction debugPrint = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ debugCommand (":print " ++ text) logOutput + Just text -> packageTry $ tryDebug $ debugCommand (":print " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugSimplePrint :: IDEAction debugSimplePrint = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ debugCommand (":force " ++ text) logOutput + Just text -> packageTry $ tryDebug $ debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugStep :: IDEAction -debugStep = packageTry_ $ do +debugStep = packageTry $ do rootPath <- lift $ activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugSetLiberalScope debugCommand ":step" (logOutputForLiveContext debugPackage) @@ -238,7 +238,7 @@ debugStepExpression :: IDEAction debugStepExpression = do maybeText <- selectedTextOrCurrentLine - packageTry_ $ tryDebug_ $ do + packageTry $ tryDebug $ do debugSetLiberalScope debugStepExpr maybeText @@ -251,23 +251,23 @@ Nothing -> lift $ ideMessage Normal "Please select an expression in the editor" debugStepLocal :: IDEAction -debugStepLocal = packageTry_ $ do +debugStepLocal = packageTry $ do rootPath <- lift $ activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":steplocal" (logOutputForLiveContext debugPackage) debugStepModule :: IDEAction -debugStepModule = packageTry_ $ do +debugStepModule = packageTry $ do rootPath <- lift $ activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":stepmodule" (logOutputForLiveContext debugPackage) debugTrace :: IDEAction -debugTrace = packageTry_ $ do +debugTrace = packageTry $ do rootPath <- lift $ activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":trace" $ do logOutputForLiveContext debugPackage @@ -277,7 +277,7 @@ debugTraceExpression :: IDEAction debugTraceExpression = do maybeText <- selectedTextOrCurrentLine - packageTry_ $ tryDebug_ $ do + packageTry $ tryDebug $ do debugSetLiberalScope debugTraceExpr maybeText @@ -294,24 +294,24 @@ debugShowBindings :: IDEAction -debugShowBindings = packageTry_ $ tryDebug_ $ debugCommand ":show bindings" logOutput +debugShowBindings = packageTry $ tryDebug $ debugCommand ":show bindings" logOutput debugShowBreakpoints :: IDEAction -debugShowBreakpoints = packageTry_ $ do +debugShowBreakpoints = packageTry $ do rootPath <- lift activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":show breaks" (logOutputForBreakpoints debugPackage) debugShowContext :: IDEAction -debugShowContext = packageTry_ $ do +debugShowContext = packageTry $ do rootPath <- lift activeProjectDir - tryDebug_ $ do + tryDebug $ do (debugPackage, _) <- ask debugCommand ":show context" (logOutputForLiveContext debugPackage) debugShowModules :: IDEAction -debugShowModules = packageTry_ $ tryDebug_ $ debugCommand ":show modules" $ +debugShowModules = packageTry $ tryDebug $ debugCommand ":show modules" $ logOutputLines_ $ \log output -> liftIO $ do case output of ToolInput line -> appendLog log (line ++ "\n") InputTag @@ -324,16 +324,16 @@ return () debugShowPackages :: IDEAction -debugShowPackages = packageTry_ $ tryDebug_ $ debugCommand ":show packages" logOutput +debugShowPackages = packageTry $ tryDebug $ debugCommand ":show packages" logOutput debugShowLanguages :: IDEAction -debugShowLanguages = packageTry_ $ tryDebug_ $ debugCommand ":show languages" logOutput +debugShowLanguages = packageTry $ tryDebug $ debugCommand ":show languages" logOutput debugInformation :: IDEAction debugInformation = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do debugSetLiberalScope debugCommand (":info "++text) logOutput Nothing -> ideMessage Normal "Please select a name in the editor" @@ -342,7 +342,7 @@ debugKind = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do debugSetLiberalScope debugCommand (":kind "++text) logOutput Nothing -> ideMessage Normal "Please select a type in the editor" @@ -351,7 +351,7 @@ debugType = do maybeText <- selectedTextOrCurrentLine case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do debugSetLiberalScope debugCommand (":type "++text) logOutput Nothing -> ideMessage Normal "Please select an expression in the editor" @@ -365,14 +365,14 @@ -- ### debugCommand (":add *"++moduleName) $ logOutputForBuild True maybeText <- selectedText case maybeText of - Just text -> packageTry_ $ tryDebug_ $ do + Just text -> packageTry $ tryDebug $ do (debugPackage, _) <- ask debugCommand' (":module *" ++ moduleName) logOutput debugCommand (":break " ++ text) (logOutputForSetBreakpoint debugPackage) Nothing -> do maybeLocation <- selectedLocation case maybeLocation of - Just (line, lineOffset) -> packageTry_ $ tryDebug_ $ do + Just (line, lineOffset) -> packageTry $ tryDebug $ do (debugPackage, _) <- ask debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " ++ (show lineOffset)) (logOutputForSetBreakpoint debugPackage) @@ -383,7 +383,7 @@ debugSet :: (Bool -> String) -> Bool -> IDEAction debugSet flag value = do - packageTry_ $ tryDebug_ $ debugCommand (":set "++(flag value)) logOutput + packageTry $ tryDebug $ debugCommand (":set "++(flag value)) logOutput debugSetPrintEvldWithShow :: Bool -> IDEAction debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -72,7 +72,7 @@ import Data.List (find, isPrefixOf) import Data.Array (bounds, (!), inRange) import IDE.Pane.Grep (grepWorkspace) -import IDE.Workspaces (workspaceTry_, packageTry_) +import IDE.Workspaces (workspaceTry, packageTry) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.Class (MonadTrans(..)) @@ -206,7 +206,7 @@ sep1 <- separatorToolItemNew toolbarInsert toolbar sep1 0 - let performGrep = (reflectIDE (packageTry_ $ doGrep toolbar) ideR) + let performGrep = (reflectIDE (packageTry $ doGrep toolbar) ideR) grepButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Grep") toolbarInsert toolbar grepButton 0 grepButton `onToolButtonClicked` performGrep @@ -458,7 +458,7 @@ wrapAround <- liftIO $ getWrapAround fb regex <- liftIO $ getRegex fb let (regexString, _) = regexStringAndMatchIndex entireWord regex search - lift $ workspaceTry_ $ grepWorkspace regexString caseSensitive + lift $ workspaceTry $ grepWorkspace regexString caseSensitive matchFunc :: ListStore String -> String -> TreeIter -> IO Bool matchFunc model str iter = do diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -345,7 +345,7 @@ if defaultExists then workspaceOpenThis False (Just defaultWorkspace) else workspaceNewHere defaultWorkspace - workspaceTryQuiet $ workspaceAddPackage' welcomeCabal + workspaceTryQuiet $ workspaceAddPackage' welcomeCabal >> return () fileOpenThis welcomeMain) ideR reflectIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))) ideR timeoutAddFull (do 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 @@ -69,7 +69,6 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Distribution.PackageDescription (hsSourceDirs) -import MyMissing(forceJust) trace a b = b @@ -168,7 +167,7 @@ newPackages let psmap2 = foldr (\e m -> Map.insert (pdPackage e) e m) psmap - (map (flip forceJust "updateSystemInfo'") + (map fromJust $ filter isJust newPackageInfos) let psmap3 = foldr (\e m -> Map.delete e m) psmap2 trashPackages let scope :: PackScope (Map String [Descr]) @@ -277,7 +276,7 @@ [] -> modPairsMb hd:_ -> hd : modPairsMb let (modWith,modWithout) = partition (\(x,y) -> isJust y) modPairsMb' - let modWithSources = map (\(f,s) -> (f,forceJust s "updatePackageInfo")) modWith + let modWithSources = map (\(f,s) -> (f,fromJust s)) modWith let modWithoutSources = map fst $ modWithout -- Now see which modules have to be truely updated modToUpdate <- if rebuild @@ -387,7 +386,7 @@ file <- openBinaryFile filePath ReadMode trace ("now loading metadata for package " ++ packageIdentifierToString pid) return () bs <- BSL.hGetContents file - let (metadataVersion'::Integer, packageInfo:: PackageDescr) = decodeSer bs + let (metadataVersion'::Integer, packageInfo::PackageDescr) = decodeSer bs if metadataVersion /= metadataVersion' then do hClose file @@ -434,7 +433,7 @@ then catch (do file <- openBinaryFile filePath ReadMode bs <- BSL.hGetContents file - let (metadataVersion'::Integer, moduleInfo:: ModuleDescr) = decodeSer bs + let (metadataVersion'::Integer, moduleInfo::ModuleDescr) = decodeSer bs if metadataVersion /= metadataVersion' then do hClose file @@ -443,8 +442,7 @@ else do moduleInfo `deepseq` (hClose file) return (Just moduleInfo)) - (\ (e :: SomeException) -> do sysMessage Normal ("loadInfosForModule: " - ++ filePath ++ " exception: " ++ show e); return Nothing) + (\ (e :: SomeException) -> do sysMessage Normal ("loadInfosForModule: " ++ show e); return Nothing) else do sysMessage Normal $"moduleInfo not found for " ++ filePath return Nothing @@ -533,7 +531,7 @@ getPackageImportInfo idePack = do mbActivePack <- readIDE activePack systemInfo' <- getSystemInfo - if isJust mbActivePack && ipdPackageId (forceJust mbActivePack "getPackageImportInfo") == ipdPackageId idePack + if isJust mbActivePack && ipdPackageId (fromJust mbActivePack) == ipdPackageId idePack then do packageInfo' <- getPackageInfo case packageInfo' of diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -54,9 +54,7 @@ , printEvldWithShowFlag , tryDebug -, tryDebug_ , tryDebugQuiet -, tryDebugQuiet_ , executeDebugCommand , choosePackageFile @@ -711,13 +709,13 @@ return ()) (\(e :: SomeException) -> putStrLn (show e)) -tryDebug :: DebugM a -> PackageM (Maybe a) +tryDebug :: DebugAction -> PackageAction tryDebug f = do maybeDebug <- lift $ readIDE debugState case maybeDebug of Just debug -> do -- TODO check debug package matches active package - liftM Just $ lift $ runDebug f debug + lift $ runDebug f debug _ -> do window <- lift $ getMainWindow resp <- liftIO $ do @@ -734,25 +732,19 @@ debugStart maybeDebug <- lift $ readIDE debugState case maybeDebug of - Just debug -> liftM Just $ lift $ runDebug f debug - _ -> return Nothing - _ -> return Nothing - -tryDebug_ :: DebugM a -> PackageAction -tryDebug_ f = tryDebug f >> return () + Just debug -> lift $ postAsyncIDE $ runDebug f debug + _ -> return () + _ -> return () -tryDebugQuiet :: DebugM a -> PackageM (Maybe a) +tryDebugQuiet :: DebugAction -> PackageAction tryDebugQuiet f = do maybeDebug <- lift $ readIDE debugState case maybeDebug of Just debug -> do -- TODO check debug package matches active package - liftM Just $ lift $ runDebug f debug + lift $ runDebug f debug _ -> do - return Nothing - -tryDebugQuiet_ :: DebugM a -> PackageAction -tryDebugQuiet_ f = tryDebugQuiet f >> return () + return () executeDebugCommand :: String -> (E.Iteratee ToolOutput IDEM ()) -> DebugAction executeDebugCommand command handler = do 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 @@ -58,7 +58,7 @@ (getSystemInfo, getWorkspaceInfo, getPackageInfo) import System.Log.Logger (infoM) import Default (Default(..)) -import IDE.Workspaces (packageTry_) +import IDE.Workspaces (packageTry) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (when) import Control.Monad.Trans.Class (MonadTrans(..)) @@ -778,7 +778,7 @@ item5 `onActivateLeaf` (treeViewCollapseAll treeView) sep2 <- separatorMenuItemNew item6 <- menuItemNewWithLabel "Add module" - item6 `onActivateLeaf` (reflectIDE (packageTry_ $ addModule' treeView store) ideR) + item6 `onActivateLeaf` (reflectIDE (packageTry $ addModule' treeView store) ideR) item7 <- menuItemNewWithLabel "Delete module" item7 `onActivateLeaf` do sel <- getSelectionTree treeView store @@ -793,10 +793,10 @@ if exists then do reflectIDE (liftIO $ removeFile fp) ideR - reflectIDE (packageTry_ $ delModule treeView store)ideR + reflectIDE (packageTry $ delModule treeView store)ideR else do - reflectIDE (packageTry_ $ delModule treeView store)ideR - reflectIDE (packageTry_ packageConfig) ideR + reflectIDE (packageTry $ delModule treeView store)ideR + reflectIDE (packageTry packageConfig) ideR return () otherwise -> return () sel <- getSelectionTree treeView store 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 @@ -23,7 +23,7 @@ import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State -import IDE.Package (tryDebug_) +import IDE.Package (tryDebug) import IDE.Debug (debugForward, debugBack, debugCommand') import IDE.Utils.Tool (ToolOutput(..)) @@ -46,7 +46,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (MouseButton(..)) import System.Log.Logger (debugM) -import IDE.Workspaces (packageTry_) +import IDE.Workspaces (packageTry) import qualified Data.Enumerator.List as EL (consume) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -158,12 +158,12 @@ return (Just pane,[ConnectC cid1]) fillTraceList :: IDEAction -fillTraceList = packageTry_ $ do +fillTraceList = packageTry $ do currentHist' <- lift $ readIDE currentHist mbTraces <- lift getPane case mbTraces of Nothing -> return () - Just tracePane -> tryDebug_ $ debugCommand' ":history" $ do + Just tracePane -> tryDebug $ debugCommand' ":history" $ do to <- EL.consume liftIO $ postGUIAsync $ do let parseRes = parse tracesParser "" (selectString to) 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 @@ -24,7 +24,7 @@ import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State -import IDE.Package (tryDebug_, tryDebugQuiet_) +import IDE.Package (tryDebug, tryDebugQuiet) import IDE.Debug (debugCommand') import IDE.Utils.Tool (ToolOutput(..)) import Text.ParserCombinators.Parsec @@ -45,7 +45,7 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..)) -import IDE.Workspaces (packageTry_, packageTryQuiet_) +import IDE.Workspaces (packageTry, packageTryQuiet) import qualified Data.Enumerator.List as EL (consume) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -140,11 +140,11 @@ fillVariablesListQuiet :: IDEAction -fillVariablesListQuiet = packageTryQuiet_ $ do +fillVariablesListQuiet = packageTryQuiet $ do mbVariables <- lift getPane case mbVariables of Nothing -> return () - Just var -> tryDebugQuiet_ $ debugCommand' ":show bindings" $ do + Just var -> tryDebugQuiet $ debugCommand' ":show bindings" $ do to <- EL.consume liftIO $ postGUIAsync $ do case parse variablesParser "" (selectString to) of @@ -157,11 +157,11 @@ insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v fillVariablesList :: IDEAction -fillVariablesList = packageTry_ $ do +fillVariablesList = packageTry $ do mbVariables <- lift getPane case mbVariables of Nothing -> return () - Just var -> tryDebug_ $ debugCommand' ":show bindings" $ do + Just var -> tryDebug $ debugCommand' ":show bindings" $ do to <- EL.consume liftIO $ postGUIAsync $ do case parse variablesParser "" (selectString to) of @@ -278,7 +278,7 @@ variablesViewPopup _ _ _ _ = throwIDE "variablesViewPopup wrong event type" forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction -forceVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do +forceVariable varDescr path treeStore = packageTry $ tryDebug $ do debugCommand' (":force " ++ (varName varDescr)) $ do to <- EL.consume liftIO $ postGUIAsync $ do @@ -297,7 +297,7 @@ treeStoreSetValue treeStore path var{varType = typ} printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction -printVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do +printVariable varDescr path treeStore = packageTry $ tryDebug $ do debugCommand' (":print " ++ (varName varDescr)) $ do to <- EL.consume liftIO $ postGUIAsync $ do 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 @@ -158,15 +158,15 @@ sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of - Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceActivatePackage ideP) ideR + Just (_,ideP) -> reflectIDE (workspaceTry $ workspaceActivatePackage ideP) ideR otherwise -> return () - item2 `onActivateLeaf` reflectIDE (workspaceTry_ $ workspaceAddPackage) ideR + item2 `onActivateLeaf` reflectIDE (workspaceTry $ workspaceAddPackage) ideR item3 `onActivateLeaf` do sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of - Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceRemovePackage ideP) ideR + Just (_,ideP) -> reflectIDE (workspaceTry $ workspaceRemovePackage ideP) ideR otherwise -> return () menuShellAppend theMenu item1 menuShellAppend theMenu item2 @@ -178,7 +178,7 @@ then do sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of - Just (_,ideP) -> reflectIDE (workspaceTry_ $ workspaceActivatePackage ideP) ideR + Just (_,ideP) -> reflectIDE (workspaceTry $ workspaceActivatePackage ideP) ideR >> return True otherwise -> return False else return False diff --git a/src/IDE/SymbolNavigation.hs b/src/IDE/SymbolNavigation.hs --- a/src/IDE/SymbolNavigation.hs +++ b/src/IDE/SymbolNavigation.hs @@ -50,10 +50,10 @@ deriving (Ord,Eq,Show) createHyperLinkSupport :: - SourceView -> -- source buffer view - ScrolledWindow -> -- container window - (Bool -> Bool -> TextIter -> IO (TextIter, TextIter)) -> -- identifiermapper (bools=control,shift) - (Bool -> Bool -> String -> IO ()) -> -- click handler + SourceView -> -- ^ source buffer view + ScrolledWindow -> -- ^ container window + (Bool -> Bool -> TextIter -> IO (TextIter, TextIter)) -> -- ^ identifiermapper (bools=control,shift) + (Bool -> Bool -> String -> IO ()) -> -- ^ click handler IO [Connection] createHyperLinkSupport sv sw identifierMapper clickHandler = do let tv = castToTextView sv @@ -240,7 +240,7 @@ let symz_ = take 50 $ sortBy (comparing getSymbolLocality) $ map (T.unpack) - $ filter (matchCamelCase (txt :: T.Text) (ttxt:: T.Text)) (symbolsT :: [T.Text]) + $ filter (matchCamelCase (txt :: T.Text) (ttxt:: T.Text)) (symbolsT ::[T.Text]) let symz = sortBy compareLocalityThenLength $ filter (not . isReexported) $ concatMap (\sym -> symLookup sym syms `mappend` symLookup sym symsP) symz_ diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -17,7 +17,6 @@ workspaceNew , workspaceOpen , workspaceTry -, workspaceTry_ , workspaceOpenThis , workspaceClose , workspaceClean @@ -30,9 +29,7 @@ , workspaceTryQuiet , workspaceNewHere , packageTry -, packageTry_ , packageTryQuiet -, packageTryQuiet_ , backgroundMake , makePackage @@ -167,23 +164,18 @@ workspaceOpenThis True mbFilePath return () -workspaceTryQuiet :: WorkspaceM a -> IDEM (Maybe a) +workspaceTryQuiet :: WorkspaceAction -> IDEAction workspaceTryQuiet f = do maybeWorkspace <- readIDE workspace case maybeWorkspace of - Just ws -> liftM Just $ runWorkspace f ws - Nothing -> do - ideMessage Normal "No workspace open" - return Nothing - -workspaceTryQuiet_ :: WorkspaceM a -> IDEAction -workspaceTryQuiet_ f = workspaceTryQuiet f >> return () + Just ws -> runWorkspace f ws + Nothing -> ideMessage Normal "No workspace open" -workspaceTry :: WorkspaceM a -> IDEM (Maybe a) +workspaceTry :: WorkspaceAction -> IDEAction workspaceTry f = do maybeWorkspace <- readIDE workspace case maybeWorkspace of - Just ws -> liftM Just $ runWorkspace f ws + Just ws -> runWorkspace f ws Nothing -> do mainWindow <- getMainWindow defaultWorkspace <- liftIO $ ( "leksah.lkshw") <$> getHomeDirectory @@ -205,20 +197,17 @@ case resp of ResponseUser 1 -> do workspaceNew - workspaceTryQuiet f + postAsyncIDE $ workspaceTryQuiet f ResponseUser 2 -> do workspaceOpen - workspaceTryQuiet f + postAsyncIDE $ workspaceTryQuiet f ResponseUser 3 -> do defaultExists <- liftIO $ doesFileExist defaultWorkspace if defaultExists then workspaceOpenThis True (Just defaultWorkspace) else workspaceNewHere defaultWorkspace - workspaceTryQuiet f - _ -> return Nothing - -workspaceTry_ :: WorkspaceM a -> IDEAction -workspaceTry_ f = workspaceTry f >> return () + postAsyncIDE $ workspaceTryQuiet f + _ -> return () chooseWorkspaceFile :: Window -> IO (Maybe FilePath) chooseWorkspaceFile window = chooseFile window "Select leksah workspace file (.lkshw)" Nothing @@ -285,7 +274,7 @@ let path = dropFileName (wsFile ws) lift $ packageNew' (Just path) (\isNew fp -> do window <- getMainWindow - workspaceTry_ $ workspaceAddPackage' fp >> return () + workspaceTry $ workspaceAddPackage' fp >> return () when isNew $ do mbPack <- idePackageFromPath fp constructAndOpenMainModule mbPack @@ -340,24 +329,18 @@ return (Just pack) Nothing -> return Nothing -packageTryQuiet :: PackageM a -> IDEM (Maybe a) +packageTryQuiet :: PackageAction -> IDEAction packageTryQuiet f = do maybePackage <- readIDE activePack case maybePackage of - Just p -> liftM Just $ runPackage f p - Nothing -> do - ideMessage Normal "No active package" - return Nothing - -packageTryQuiet_ :: PackageM a -> IDEAction -packageTryQuiet_ f = packageTryQuiet f >> return () + Just p -> runPackage f p + Nothing -> ideMessage Normal "No active package" -packageTry :: PackageM a -> IDEM (Maybe a) -packageTry f = do - liftM (>>= id) $ workspaceTry $ do +packageTry :: PackageAction -> IDEAction +packageTry f = workspaceTry $ do maybePackage <- lift $ readIDE activePack case maybePackage of - Just p -> liftM Just $ lift $ runPackage f p + Just p -> lift $ runPackage f p Nothing -> do window <- lift $ getMainWindow resp <- liftIO $ do @@ -373,14 +356,11 @@ case resp of ResponseUser 1 -> do workspacePackageNew - lift $ packageTryQuiet f + lift $ postAsyncIDE $ packageTryQuiet f ResponseUser 2 -> do workspaceAddPackage - lift $ packageTryQuiet f - _ -> return Nothing - -packageTry_ :: PackageM a -> IDEAction -packageTry_ f = packageTry f >> return () + lift $ postAsyncIDE $ packageTryQuiet f + _ -> return () workspaceRemovePackage :: IDEPackage -> WorkspaceAction workspaceRemovePackage pack = do @@ -548,13 +528,13 @@ when isModified $ do let settings = defaultMakeSettings prefs if msSingleBuildWithoutLinking settings && not (msMakeMode settings) - then workspaceTryQuiet_ $ + then workspaceTryQuiet $ makePackages settings modifiedPacks MoBuild (MoComposed []) moNoOp else do let steps = if msRunUnitTests settings then [MoBuild,MoTest,MoCopy,MoRegister] else [MoBuild,MoCopy,MoRegister] - workspaceTryQuiet_ $ + workspaceTryQuiet $ makePackages settings modifiedPacks (MoComposed steps) (MoComposed (MoConfigure:steps)) MoMetaInfo )