System/Console/Haskeline/Command/History.hs

    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
    import Data.IORef
    import Control.Monad.Catch

    data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]}
                        deriving Show

    prevHistoryM :: [Grapheme] -> HistLog -> Maybe ([Grapheme],HistLog)
    prevHistoryM _ HistLog {pastHistory = []} = Nothing
    prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future}
            = Just (ls,
                HistLog {pastHistory=past, futureHistory= s:future})

    prevHistories :: [Grapheme] -> HistLog -> [([Grapheme],HistLog)]
    prevHistories s h = flip unfoldr (s,h) $ \(s',h') -> fmap (\r -> (r,r))
                        $ prevHistoryM s' h'

    histLog :: History -> HistLog
    histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist,
                            futureHistory = []}

    runHistoryFromFile :: (MonadIO m, MonadMask m) => Maybe FilePath -> Maybe Int
                                -> ReaderT (IORef History) m a -> m a
    runHistoryFromFile Nothing _ f = do
        historyRef <- liftIO $ newIORef emptyHistory
        runReaderT f historyRef
    runHistoryFromFile (Just file) stifleAmt f = do
        oldHistory <- liftIO $ readHistory file
        historyRef <- liftIO $ newIORef $ stifleHistory stifleAmt oldHistory
        -- Run the action and then write the new history, even on an exception.
        -- For example, if there's an unhandled ctrl-c, we don't want to lose
        -- the user's previously-entered commands.
        -- (Note that this requires using ReaderT (IORef History) instead of StateT.
        x <- runReaderT f historyRef
                `finally` (liftIO $ readIORef historyRef >>= writeHistory file)
        return x

    prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog)
    prevHistory s h = let (s',h') = fromMaybe (listSave s,h)
                                        $ prevHistoryM (listSave s) h
                      in (listRestore s',h')

    firstHistory s h = let prevs = (listSave s,h):prevHistories (listSave s) h
                           -- above makes sure we don't take the last of an empty list.
                           (s',h') = last prevs
                       in (listRestore s',h')

    historyBack, historyForward :: (Save s, MonadState HistLog m) => Command m s s
    historyBack = simpleCommand $ histUpdate prevHistory
    historyForward = simpleCommand $ reverseHist . histUpdate prevHistory

    historyStart, historyEnd :: (Save s, MonadState HistLog m) => Command m s s
    historyStart = simpleCommand $ histUpdate firstHistory
    historyEnd = simpleCommand $ reverseHist . histUpdate firstHistory

    histUpdate :: MonadState HistLog m => (s -> HistLog -> (t,HistLog))
                            -> s -> m (Either Effect t)
    histUpdate f = liftM Right . 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 :: [Grapheme],
                                  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 = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`")
                                ++ searchTerm sm ++ stringToGraphemes "': "
        afterCursor = afterCursor . foundHistory

    instance Result SearchMode where
        toResult = toResult . foundHistory

    saveSM :: SearchMode -> [Grapheme]
    saveSM = listSave . foundHistory

    startSearchMode :: Direction -> InsertMode -> SearchMode
    startSearchMode dir im = SearchMode {searchTerm = [],foundHistory=im, direction=dir}

    addChar :: Char -> SearchMode -> SearchMode
    addChar c s = s {searchTerm = listSave $ insertChar c
                                    $ listRestore $ searchTerm s}

    searchHistories :: Direction -> [Grapheme] -> [([Grapheme],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 :: [Grapheme] -> [Grapheme] -> 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 -> ([Grapheme],[([Grapheme],HistLog)])
    prepSearch sm h = let
        text = searchTerm sm
        l = saveSM 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 (saveSM s,h):hists else hists
        in searchHistories (direction s) text hists'

    doSearch :: MonadState HistLog m => Bool -> SearchMode -> m (Either 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 (Right sm')
                Nothing -> return $ Left RingBell

    searchHistory :: MonadState HistLog m => KeyCommand m InsertMode InsertMode
    searchHistory = choiceCmd [
                metaChar 'j' +> searchForPrefix Forward
                , metaChar 'k' +> searchForPrefix Reverse
                , choiceCmd [
                     backKey +> change (startSearchMode Reverse)
                     , forwardKey +> change (startSearchMode Forward)
                     ] >+> keepSearching
                ]
        where
            backKey = ctrlChar 'r'
            forwardKey = ctrlChar 's'
            keepSearching = keyChoiceCmd [
                                choiceCmd [
                                    charCommand oneMoreChar
                                    , backKey +> simpleCommand (searchMore Reverse)
                                    , forwardKey +> simpleCommand (searchMore Forward)
                                    , simpleKey Backspace +> change delLastChar
                                    ] >+> keepSearching
                                , withoutConsuming (change foundHistory) -- abort
                                ]
            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}

    searchForPrefix :: MonadState HistLog m => Direction
                        -> Command m InsertMode InsertMode
    searchForPrefix dir s@(IMode xs _) = do
        next <- findFirst prefixed dir s
        maybe (return s) setState next
      where
        prefixed gs = if rxs `isPrefixOf` gs
                        then Just $ IMode xs (drop (length xs) gs)
                        else Nothing
        rxs = reverse xs

    -- Search for the first entry in the history which satisfies the constraint.
    -- If it succeeds, the HistLog is updated and the result is returned.
    -- If it fails, the HistLog is unchanged.
    -- TODO: make the other history searching functions use this instead.
    findFirst :: forall s m . (Save s, MonadState HistLog m)
        => ([Grapheme] -> Maybe s) -> Direction -> s -> m (Maybe s)
    findFirst cond Forward s = reverseHist $ findFirst cond Reverse s
    findFirst cond Reverse s = do
        hist <- get
        case search (prevHistories (listSave s) hist) of
            Nothing -> return Nothing
            Just (s',hist') -> put hist' >> return (Just s')
      where
        search :: [([Grapheme],HistLog)] -> Maybe (s,HistLog)
        search [] = Nothing
        search ((g,h):gs) = case cond g of
            Nothing -> search gs
            Just s' -> Just (s',h)