module System.Console.Haskeline.Command.History where
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Command
import System.Console.Haskeline.Key
import Control.Monad(liftM,mplus)
import System.Console.Haskeline.Monads
import Data.List
import Data.Maybe(fromMaybe)
import System.Console.Haskeline.History
data HistLog = HistLog {pastHistory, futureHistory :: [String]}
deriving Show
prevHistoryM :: String -> HistLog -> Maybe (String,HistLog)
prevHistoryM _ HistLog {pastHistory = []} = Nothing
prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future}
= Just (ls,
HistLog {pastHistory=past, futureHistory= s:future})
prevHistories :: String -> HistLog -> [(String,HistLog)]
prevHistories s h = flip unfoldr (s,h) $ \(s',h') -> fmap (\r -> (r,r))
$ prevHistoryM s' h'
histLog :: History -> HistLog
histLog hist = HistLog {pastHistory = historyLines hist, futureHistory = []}
runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a
runHistoryFromFile Nothing _ f = evalStateT' emptyHistory f
runHistoryFromFile (Just file) stifleAmt f = do
oldHistory <- liftIO $ readHistory file
(x,newHistory) <- runStateT f (stifleHistory stifleAmt oldHistory)
liftIO $ writeHistory file newHistory
return x
runHistLog :: Monad m => StateT HistLog m a -> StateT History m a
runHistLog f = do
history <- get
lift (evalStateT' (histLog history) f)
prevHistory :: FromString s => s -> HistLog -> (s, HistLog)
prevHistory s h = let (s',h') = fromMaybe (toResult s,h) $ prevHistoryM (toResult s) h
in (fromString s',h')
historyBack, historyForward :: (FromString s, MonadState HistLog m) =>
Key -> Command m s s
historyBack = simpleCommand $ histUpdate prevHistory
historyForward = simpleCommand $ reverseHist . histUpdate prevHistory
histUpdate :: MonadState HistLog m => (s -> HistLog -> (t,HistLog))
-> s -> m (Effect t)
histUpdate f = liftM Change . update . f
reverseHist :: MonadState HistLog m => m b -> m b
reverseHist f = do
modify reverser
y <- f
modify reverser
return y
where
reverser h = HistLog {futureHistory=pastHistory h,
pastHistory=futureHistory h}
data SearchMode = SearchMode {searchTerm :: String,
foundHistory :: InsertMode,
direction :: Direction}
deriving Show
data Direction = Forward | Reverse
deriving (Show,Eq)
directionName :: Direction -> String
directionName Forward = "i-search"
directionName Reverse = "reverse-i-search"
instance LineState SearchMode where
beforeCursor _ sm = beforeCursor prefix (foundHistory sm)
where
prefix = "(" ++ directionName (direction sm) ++ ")`"
++ searchTerm sm ++ "': "
afterCursor = afterCursor . foundHistory
instance Result SearchMode where
toResult = toResult . foundHistory
startSearchMode :: Direction -> InsertMode -> SearchMode
startSearchMode dir im = SearchMode {searchTerm = "",foundHistory=im, direction=dir}
addChar :: Char -> SearchMode -> SearchMode
addChar c s = s {searchTerm = searchTerm s ++ [c]}
searchHistories :: Direction -> String -> [(String,HistLog)] -> Maybe (SearchMode,HistLog)
searchHistories dir text = foldr mplus Nothing . map findIt
where
findIt (l,h) = do
im <- findInLine text l
return (SearchMode text im dir,h)
findInLine :: String -> String -> Maybe InsertMode
findInLine text l = find' [] l
where
find' _ "" = Nothing
find' prev ccs@(c:cs)
| text `isPrefixOf` ccs = Just (IMode prev ccs)
| otherwise = find' (c:prev) cs
prepSearch :: SearchMode -> HistLog -> (String,[(String,HistLog)])
prepSearch sm h = let
text = searchTerm sm
l = toResult sm
in (text,prevHistories l h)
searchBackwards :: Bool -> SearchMode -> HistLog -> Maybe (SearchMode, HistLog)
searchBackwards useCurrent s h = let
(text,hists) = prepSearch s h
hists' = if useCurrent then (toResult s,h):hists else hists
in searchHistories (direction s) text hists'
doSearch :: MonadState HistLog m => Bool -> SearchMode -> m (Effect SearchMode)
doSearch useCurrent sm = case direction sm of
Reverse -> searchHist
Forward -> reverseHist searchHist
where
searchHist = do
hist <- get
case searchBackwards useCurrent sm hist of
Just (sm',hist') -> put hist' >> return (Change sm')
Nothing -> return (RingBell sm)
searchHistory :: MonadState HistLog m => Command m InsertMode InsertMode
searchHistory = choiceCmd [
backKey +> change (startSearchMode Reverse)
, forwardKey +> change (startSearchMode Forward)
] >|> keepSearching
where
backKey = ctrlChar 'r'
forwardKey = ctrlChar 's'
keepSearching = choiceCmd [
choiceCmd [
charCommand oneMoreChar
, backKey +> simpleCommand (searchMore Reverse)
, forwardKey +> simpleCommand (searchMore Forward)
, simpleKey Backspace +> change delLastChar
] >|> keepSearching
, changeWithoutKey foundHistory
]
delLastChar s = s {searchTerm = minit (searchTerm s)}
minit xs = if null xs then "" else init xs
oneMoreChar c = doSearch True . addChar c
searchMore d s = doSearch False s {direction=d}