Support flushing command history

System/Console/Haskeline.hs

@@ -67,6 +67,7 @@ module System.Console.Haskeline(
                     getHistory,
                     putHistory,
                     modifyHistory,
+                    flushHistory,
                     -- * Ctrl-C handling
                     withInterrupt,
                     Interrupt(..),
@@ -92,6 +93,7 @@ import System.Console.Haskeline.RunCommand
 
 import System.IO
 import Data.Char (isSpace, isPrint)
+import Control.Monad (when)
 
 
 -- | A useful default.  In particular:
@@ -182,13 +184,16 @@ maybeAddHistory :: forall m . MonadIO m => Maybe String -> InputT m ()
 maybeAddHistory result = do
     settings :: Settings m <- InputT ask
     histDupes <- InputT $ asks historyDuplicates
+    doFlush <- InputT $ asks flushEveryCommand
     case result of
         Just line | autoAddHistory settings && not (all isSpace line) 
             -> let adder = case histDupes of
                         AlwaysAdd -> addHistory
                         IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe
                         IgnoreAll -> addHistoryRemovingAllDupes
-               in modifyHistory (adder line)
+               in do
+                modifyHistory (adder line)
+                when doFlush flushHistory
         _ -> return ()
 
 ----------

System/Console/Haskeline/InputT.hs

@@ -23,10 +23,9 @@ data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab comple
                             historyFile :: Maybe FilePath, -- ^ Where to read/write the history at the
                                                         -- start and end of each
                                                         -- line input session.
-                            autoAddHistory :: Bool -- ^ If 'True', each nonblank line returned by
+                            autoAddHistory :: Bool  -- ^ If 'True', each nonblank line returned by
                                 -- @getInputLine@ will be automatically added to the history.
-
-                            }
+                           }
 
 -- | Because 'complete' is the only field of 'Settings' depending on @m@,
 -- the expression @defaultSettings {completionFunc = f}@ leads to a type error
@@ -64,6 +63,17 @@ getHistory = InputT get
 putHistory :: MonadIO m => History -> InputT m ()
 putHistory = InputT . put
 
+-- | Writes command history to file if 'historyFile' is not 'Nothing'
+flushHistory :: forall m . MonadIO m => InputT m ()
+flushHistory = do
+    settings :: Settings m <- InputT ask
+    getHistory >>= maybeFlushHistory (historyFile settings)
+
+-- | Flushes history if given filepath is not 'Nothing'
+maybeFlushHistory :: MonadIO m => Maybe FilePath -> History -> InputT m ()
+maybeFlushHistory Nothing _ = return ()
+maybeFlushHistory (Just f) hist = liftIO $ writeHistory f hist
+
 -- | Change the current line input history.
 modifyHistory :: MonadIO m => (History -> History) -> InputT m ()
 modifyHistory = InputT . modify

System/Console/Haskeline/Prefs.hs

@@ -47,7 +47,10 @@ data Prefs = Prefs { bellStyle :: !BellStyle,
                         -- presses @TAB@ again.
                      customBindings :: Map.Map Key [Key],
                         -- (termName, keysequence, key)
-                     customKeySequences :: [(Maybe String, String,Key)]
+                     customKeySequences :: [(Maybe String, String,Key)],
+                     flushEveryCommand :: Bool 
+                        -- ^ If 'True' and @historyFile@ not 'Nothing'    
+                        -- flushes command history after every command
                      }
                         deriving Show
 
@@ -76,8 +79,9 @@ defaultPrefs = Prefs {bellStyle = AudibleBell,
                       listCompletionsImmediately = True,
                       historyDuplicates = AlwaysAdd,
                       customBindings = Map.empty,
-                      customKeySequences = []
-                    }
+                      customKeySequences = [],
+                      flushEveryCommand = False
+                     }
 
 mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
 mkSettor f str = maybe id f (readMaybe str)