long operations are now threaded and can be stopped

README.md

@@ -91,7 +91,6 @@ Complete explanation from [Brick.Themes](https://hackage.haskell.org/package/bri
 > Attribute names with multiple components (e.g. attr1 <> attr2) can be referenced in customization files by separating the names with a dot. For example, the attribute name "list" <> "selected" can be referenced by using the string "list.selected".
 
 ## TODOs
-- treaded IO operations (that do not freeze the UI and can be canceled)
 - more settings (using command line arguments)
 - mc directory comparison
 - multi-pane view

clifm.cabal

@@ -10,7 +10,7 @@ name:                clifm
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.2.1.3
+version:             0.2.2.0
 
 -- A short (one-line) description of the package.
 synopsis:            Command Line Interface File Manager

src/Main.hs

@@ -1,6 +1,7 @@
 module Main where
 import Types
 import Widgets.Manager
+import Widgets.Tab (Tab)
 
 import Options.Applicative
 import System.Directory (doesDirectoryExist, doesFileExist, makeAbsolute)
@@ -9,6 +10,7 @@ import Control.Monad (void)
 import Brick.Main (customMain, showFirstCursor, App(..))
 import Brick.Themes (Theme, themeToAttrMap, loadCustomizations)
 import Brick.AttrMap (AttrMap)
+import Brick.BChan (newBChan)
 import Graphics.Vty (mkVty, standardIOConfig, setMode, outputIface, Mode(Mouse))
 
 -- entry point: parses the arguments and starts the brick application
@@ -66,10 +68,11 @@ runUI options = do
         v <- mkVty =<< standardIOConfig
         setMode (outputIface v) Mouse True
         return v
-  state <- makeState path $ editComm options
-  void $ customMain buildVty Nothing (app atrm) state
+  eventChan <- Brick.BChan.newBChan 10
+  state <- makeState path (editComm options) eventChan
+  void $ customMain buildVty (Just eventChan) (app atrm) state
 
-app :: AttrMap -> App State e Name
+app :: AttrMap -> App State (ThreadEvent Tab) Name
 app atrm = App { appDraw = drawUi,
     appStartEvent = return,
     appHandleEvent = handleEvent,

src/Types.hs

@@ -10,8 +10,9 @@ import Brick.Util (on, fg, bg)
 import Brick.Widgets.Edit (editFocusedAttr)
 import Brick.Widgets.List (listSelectedFocusedAttr)
 
--- names
+-- names and events
 data Name = BVal Char Bool | LScroll | LNum Int | PEdit | EList deriving (Ord, Show, Eq)
+data ThreadEvent a = ThreadClosed | ThreadSuccess a | ThreadError String
 
 -- attributes and themes
 defaultTheme :: Theme

src/Widgets/Manager.hs

@@ -13,17 +13,25 @@ import Brick.Widgets.Core ((<+>), str, hBox, vBox, vLimit, viewport, withBorderS
 import Brick.Types (Widget, BrickEvent(..), EventM, Next, ViewportType(..), Location(..))
 import Brick.Widgets.Border (border, hBorder, borderWithLabel)
 import Brick.Widgets.Border.Style (unicodeBold)
+import Brick.BChan (BChan)
 import Graphics.Vty (Event(EvKey), Key(..), Modifier(MCtrl))
 import Data.Foldable (toList)
 import Data.List.PointedList (PointedList, _focus, replace, delete, singleton, insert, insertLeft, moveTo, withFocus, atStart, atEnd)
 import Data.List.PointedList.Circular (next, previous)
 
-data State = State {tabZipper :: TabZipper, clipboard :: Clipboard, prompt :: Maybe Prompt, editorCommand :: String}
+data State = State {tabZipper :: TabZipper,
+    clipboard :: Clipboard,
+    prompt :: Maybe Prompt,
+    editorCommand :: String,
+    eventChan :: BChan (ThreadEvent Tab)
+  }
 type TabZipper = PointedList Tab
 
 -- creation functions
-makeState :: FilePath -> String -> IO State
-makeState path editCom = (\zp -> State zp EmptyBoard Nothing editCom) <$> makeTabZipper path
+makeState :: FilePath -> String -> BChan (ThreadEvent Tab) -> IO State
+makeState path editCom eChan = do
+  zp <- makeTabZipper path
+  return $ State zp EmptyBoard Nothing editCom eChan
 
 makeTabZipper :: FilePath -> IO TabZipper
 makeTabZipper path = singleton <$> makeDirTab path
@@ -70,20 +78,19 @@ indipendentButtons = [
   ]
 
 -- event handling functions
-handleEvent :: State -> BrickEvent Name e -> EventM Name (Next State)
+handleEvent :: State -> BrickEvent Name (ThreadEvent Tab) -> EventM Name (Next State)
 handleEvent state event = case prompt state of
   Just pr -> handlePrompt event pr state
   _ -> handleMain event state
 
-handlePrompt :: BrickEvent Name e -> Prompt -> State -> EventM Name (Next State)
-handlePrompt (VtyEvent ev) pr state = do
-  promptRes <- handlePromptEvent ev pr
+handlePrompt :: BrickEvent Name (ThreadEvent Tab) -> Prompt -> State -> EventM Name (Next State)
+handlePrompt ev pr state = do
+  promptRes <- handlePromptEvent ev pr (eventChan state)
   case promptRes of
     Left pr -> updatePrompt pr state --updates the prompt and keeps it up
     Right tab -> updateZipper (replace tab) state --replaces with the resulting tab and closes the prompt
-handlePrompt _ _ state = continue state
 
-handleMain :: BrickEvent Name e -> State -> EventM Name (Next State)
+handleMain :: BrickEvent Name (ThreadEvent Tab) -> State -> EventM Name (Next State)
 handleMain (VtyEvent ev) = case ev of
   EvKey KEsc [] -> halt
   EvKey (KChar 'q') [] -> halt

src/Widgets/Prompt.hs

@@ -4,15 +4,19 @@ import Widgets.Tab
 import Widgets.Clipboard
 
 import Data.Monoid ((<>))
+import Data.Functor (($>))
 import Control.Monad(when,forM_)
 import Control.Monad.IO.Class (liftIO)
-import Control.Exception (try, throw, displayException, SomeException)
+import Control.Concurrent (threadDelay, forkFinally, ThreadId, killThread)
+import Control.Exception (try, throw, displayException, SomeException, fromException)
+import Control.Exception.Base (AsyncException(ThreadKilled))
 import Control.Applicative ((*>), (<$>))
 import Brick.Widgets.Core ((<+>), str, strWrap, vBox, hLimit, padLeftRight, padTopBottom, withDefAttr)
 import Brick.Widgets.Border (borderWithLabel, hBorder)
-import Brick.Types (Widget, EventM)
+import Brick.Types (Widget, EventM, BrickEvent(..))
 import Brick.Widgets.Center (centerLayer, hCenter)
 import Brick.Widgets.Edit (Editor, editor, renderEditor, getEditContents, handleEditorEvent)
+import Brick.BChan (BChan, writeBChan)
 import Graphics.Vty (Event(EvKey), Key(..))
 import Data.Time.Format (formatTime, defaultTimeLocale)
 import System.FilePath (isValid, takeDirectory, (</>), takeFileName)
@@ -24,7 +28,8 @@ data Prompt = Prompt {originTab :: Tab, action :: PromptAction} deriving Show
 type PathEditor = Editor FilePath Name
 data PromptAction = Copy Entry FilePath | Cut Entry FilePath | Rename PathEditor Entry |
   Delete Entry | Mkdir PathEditor FilePath | Touch PathEditor FilePath |
-  GoTo PathEditor | Search PathEditor FilePath | DisplayInfo EntryInfo | DisplayError String
+  GoTo PathEditor | Search PathEditor FilePath | DisplayInfo EntryInfo |
+  DisplayError String | Performing String ThreadId
 
 instance Show PromptAction where
   show (Copy _ _) = " Copy "
@@ -36,6 +41,7 @@ instance Show PromptAction where
   show (GoTo _) = " Go To "
   show (DisplayInfo _) = " Entry Info "
   show (Search _ _) = " Search "
+  show (Performing name _) = " Performing" ++ name
   show _ = " Error "
 
 -- creation functions
@@ -105,6 +111,7 @@ renderBody pr = vBox $ case action pr of
   Search edit _ -> str "Search for:" : renderValidatedEditor edit
   DisplayInfo info -> map strWrap . (displaySize info :) $ displayPerms info ++ displayTimes info
   DisplayError msg -> [str "Whoops, this went wrong:", withDefAttr errorAttr $ strWrap msg]
+  Performing name _ -> [str $ "Performing" ++ name, str "Please wait"]
 
 displaySize :: EntryInfo -> String
 displaySize info = "Size: " ++ show (entrySize info) ++ " Bytes (" ++ shortEntrySize info ++ ")"
@@ -134,7 +141,7 @@ tellEntry e = case e of
 disclaimer :: Widget Name
 disclaimer = withDefAttr disclaimerAttr $ strWrap "NOTE: this will operate on \
   \your file system and may be irreversible, double check it! Also please note \
-  \that when this operation starts the UI will be unresponsive until it's done."
+  \that the operation can be stopped, but will not revert what was already done."
 
 renderValidatedEditor :: PathEditor -> [Widget Name]
 renderValidatedEditor e = [renderEditor (str . unlines) True e, validLine]
@@ -144,7 +151,9 @@ renderValidatedEditor e = [renderEditor (str . unlines) True e, validLine]
       else withDefAttr errorAttr $ str " ^ invalid filepath!"
 
 renderFooter :: PromptAction -> Widget Name
-renderFooter act = kb "Enter" <+> str txt <+> kb "Esc" <+> str " to close and go back"
+renderFooter act = case act of
+  Performing _ _ -> kb "Esc" <+> str " to Cancel. NOTE: will not revert what was already done."
+  _ -> kb "Enter" <+> str txt <+> kb "Esc" <+> str " to close and go back"
   where
     kb = withDefAttr keybindAttr . str
     txt = case act of
@@ -159,11 +168,47 @@ renderFooter act = kb "Enter" <+> str txt <+> kb "Esc" <+> str " to close and go
       _ -> " or "
 
 -- event-handling functions
-handlePromptEvent :: Event -> Prompt -> EventM Name (Either Prompt Tab)
-handlePromptEvent ev pr = case ev of
-  EvKey KEsc [] -> return . Right $ originTab pr
-  EvKey KEnter [] -> liftIO $ tryProcessAction pr
+handlePromptEvent :: BrickEvent Name (ThreadEvent Tab) -> Prompt -> BChan (ThreadEvent Tab) -> EventM Name (Either Prompt Tab)
+handlePromptEvent (AppEvent ev) pr _ = case ev of
+  ThreadError err -> return $ Left pr {action = DisplayError err}
+  ThreadSuccess tab -> return $ Right tab
+  ThreadClosed -> return . Right $ originTab pr
+handlePromptEvent (VtyEvent ev) pr eChan = case ev of
+  EvKey KEsc [] -> liftIO $ exitPrompt pr
+  EvKey KEnter [] -> liftIO $ performAction pr eChan
   _ -> Left . Prompt (originTab pr) <$> handleActionEditor ev (action pr)
+handlePromptEvent _ pr _ = return $ Left pr
+
+exitPrompt :: Prompt -> IO (Either Prompt Tab)
+exitPrompt pr = case action pr of
+  Performing name tId -> killThread tId $> Left pr -- returns the same prompt because the actual exiting will happen because of the exception that killThread raises
+  _ -> return . Right $ originTab pr
+
+-- gets to decide if the action will be processed in a different thread or not
+performAction :: Prompt -> BChan (ThreadEvent Tab) -> IO (Either Prompt Tab) --
+performAction pr eChan = case action pr of
+  Copy _ _ -> Left <$> processThreaded pr eChan
+  Cut _ _ -> Left <$> processThreaded pr eChan
+  Rename _ _ -> Left <$> processThreaded pr eChan
+  Delete _ -> Left <$> processThreaded pr eChan
+  Search _ _ -> Left <$> processThreaded pr eChan
+  Performing _ _ -> return $ Left pr -- doesn't really make sense
+  _ -> tryProcessAction pr
+
+processThreaded :: Prompt -> BChan (ThreadEvent Tab) -> IO Prompt
+processThreaded pr eChan = do
+  tId <- forkFinally (processAction pr) (reportResult eChan)
+  return $ pr {action = Performing (show $ action pr) tId}
+
+reportResult :: BChan (ThreadEvent Tab) -> Either SomeException Tab -> IO ()
+reportResult eChan res = writeBChan eChan $ case res of
+  Left e -> endingEvent e
+  Right tabRes -> ThreadSuccess tabRes
+
+endingEvent :: SomeException -> ThreadEvent Tab
+endingEvent e = case (fromException e :: Maybe AsyncException) of
+  Just ThreadKilled -> ThreadClosed
+  _ -> ThreadError $ displayException e
 
 tryProcessAction :: Prompt -> IO (Either Prompt Tab)
 tryProcessAction pr = do