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 -- 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}