{- |
This module provides a low-level API to the line history stored in the @InputT@ monad transformer.


For most application, it should suffice to instead use the following @Settings@ flags:

  * @autoAddHistory@: add nonblank lines to the command history ('True' by default).

  * @historyFile@: read/write the history to a file before and after the line input session.

If you do want custom history behavior, you may need to disable the above default setting(s).

-}
module System.Console.Haskeline.History(
                        History(),
                        emptyHistory,
                        addHistory,
                        addHistoryUnlessConsecutiveDupe,
                        addHistoryRemovingAllDupes,
                        historyLines,
                        readHistory,
                        writeHistory,
                        stifleHistory,
                        stifleAmount,
                        ) where

import qualified Data.Sequence as Seq
import Data.Sequence ( Seq, (<|), ViewL(..), ViewR(..), viewl, viewr )
import Data.Foldable (toList)

import Control.Exception

import System.Directory(doesFileExist)

import qualified System.IO as IO
import System.Console.Haskeline.Recover

data History = History {History -> Seq String
histLines :: Seq String,
                        History -> Maybe Int
stifleAmt :: Maybe Int}
                    -- stored in reverse

-- | The maximum number of lines stored in the history.  If 'Nothing', the history storage is unlimited.
stifleAmount :: History -> Maybe Int
stifleAmount :: History -> Maybe Int
stifleAmount = History -> Maybe Int
stifleAmt

instance Show History where
    show :: History -> String
show = Seq String -> String
forall a. Show a => a -> String
show (Seq String -> String)
-> (History -> Seq String) -> History -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> Seq String
histLines

emptyHistory :: History
emptyHistory :: History
emptyHistory = Seq String -> Maybe Int -> History
History Seq String
forall a. Seq a
Seq.empty Maybe Int
forall a. Maybe a
Nothing

-- | The input lines stored in the history (newest first)
historyLines :: History -> [String]
historyLines :: History -> [String]
historyLines = Seq String -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq String -> [String])
-> (History -> Seq String) -> History -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> Seq String
histLines

-- | Reads the line input history from the given file.  Returns
-- 'emptyHistory' if the file does not exist or could not be read.
readHistory :: FilePath -> IO History
readHistory :: String -> IO History
readHistory String
file = (IOException -> IO History) -> IO History -> IO History
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_::IOException) -> History -> IO History
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return History
emptyHistory) (IO History -> IO History) -> IO History -> IO History
forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- String -> IO Bool
doesFileExist String
file
    String
contents <- if Bool
exists
        then String -> IO String
readUTF8File String
file
        else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents) -- force file closed
    History -> IO History
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return History {histLines :: Seq String
histLines = [String] -> Seq String
forall a. [a] -> Seq a
Seq.fromList ([String] -> Seq String) -> [String] -> Seq String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
contents,
                    stifleAmt :: Maybe Int
stifleAmt = Maybe Int
forall a. Maybe a
Nothing}

-- | Writes the line history to the given file.  If there is an
-- error when writing the file, it will be ignored.
writeHistory :: FilePath -> History -> IO ()
writeHistory :: String -> History -> IO ()
writeHistory String
file = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(IOException
_::IOException) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        (IO () -> IO ()) -> (History -> IO ()) -> History -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
writeUTF8File String
file
        (String -> IO ()) -> (History -> String) -> History -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (History -> [String]) -> History -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> [String]
historyLines 

-- | Limit the number of lines stored in the history.
stifleHistory :: Maybe Int -> History -> History
stifleHistory :: Maybe Int -> History -> History
stifleHistory Maybe Int
Nothing History
hist = History
hist {stifleAmt :: Maybe Int
stifleAmt = Maybe Int
forall a. Maybe a
Nothing}
stifleHistory a :: Maybe Int
a@(Just Int
n) History
hist = History {histLines :: Seq String
histLines = Seq String -> Seq String
forall {a}. Seq a -> Seq a
stifleFnc (History -> Seq String
histLines History
hist),
                                stifleAmt :: Maybe Int
stifleAmt = Maybe Int
a}
    where
        stifleFnc :: Seq a -> Seq a
stifleFnc = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Seq String -> Int
forall a. Seq a -> Int
Seq.length (History -> Seq String
histLines History
hist)
                        then Seq a -> Seq a
forall a. a -> a
id
                        else [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> (Seq a -> [a]) -> Seq a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> (Seq a -> [a]) -> Seq a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

addHistory :: String -> History -> History
addHistory :: String -> History -> History
addHistory String
s History
h = History
h {histLines :: Seq String
histLines = Maybe Int -> Seq String -> Seq String
forall a. Maybe Int -> Seq a -> Seq a
maybeDropLast (History -> Maybe Int
stifleAmt History
h) (String
s String -> Seq String -> Seq String
forall a. a -> Seq a -> Seq a
<| (History -> Seq String
histLines History
h))}

-- If the sequence is too big, drop the last entry.
maybeDropLast :: Maybe Int -> Seq a -> Seq a
maybeDropLast :: forall a. Maybe Int -> Seq a -> Seq a
maybeDropLast Maybe Int
maxAmt Seq a
hs
    | Bool
rightSize = Seq a
hs
    | Bool
otherwise = case Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr Seq a
hs of
                    ViewR a
EmptyR -> Seq a
hs
                    Seq a
hs' :> a
_ -> Seq a
hs'
  where
    rightSize :: Bool
rightSize = Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
hs) Maybe Int
maxAmt

-- | Add a line to the history unless it matches the previously recorded line.
addHistoryUnlessConsecutiveDupe :: String -> History -> History
addHistoryUnlessConsecutiveDupe :: String -> History -> History
addHistoryUnlessConsecutiveDupe String
h History
hs = case Seq String -> ViewL String
forall a. Seq a -> ViewL a
viewl (History -> Seq String
histLines History
hs) of
    String
h1 :< Seq String
_ | String
hString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
h1   -> History
hs
    ViewL String
_                   -> String -> History -> History
addHistory String
h History
hs

-- | Add a line to the history, and remove all previous entries which are the 
-- same as it.
addHistoryRemovingAllDupes :: String -> History -> History
addHistoryRemovingAllDupes :: String -> History -> History
addHistoryRemovingAllDupes String
h History
hs = String -> History -> History
addHistory String
h History
hs {histLines :: Seq String
histLines = Seq String
filteredHS}
  where
    filteredHS :: Seq String
filteredHS = [String] -> Seq String
forall a. [a] -> Seq a
Seq.fromList ([String] -> Seq String) -> [String] -> Seq String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
h) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Seq String -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq String -> [String]) -> Seq String -> [String]
forall a b. (a -> b) -> a -> b
$ History -> Seq String
histLines History
hs

---------
-- UTF-8 file I/O, for old versions of GHC

readUTF8File :: FilePath -> IO String
readUTF8File :: String -> IO String
readUTF8File String
file = do
    Handle
h <- String -> IOMode -> IO Handle
IO.openFile String
file IOMode
IO.ReadMode
    Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h (TextEncoding -> IO ()) -> TextEncoding -> IO ()
forall a b. (a -> b) -> a -> b
$ TextEncoding -> TextEncoding
transliterateFailure TextEncoding
IO.utf8
    Handle -> NewlineMode -> IO ()
IO.hSetNewlineMode Handle
h NewlineMode
IO.noNewlineTranslation
    String
contents <- Handle -> IO String
IO.hGetContents Handle
h
    Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contents)
    Handle -> IO ()
IO.hClose Handle
h
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
contents

writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File :: String -> String -> IO ()
writeUTF8File String
file String
contents = do
    Handle
h <- String -> IOMode -> IO Handle
IO.openFile String
file IOMode
IO.WriteMode
    Handle -> TextEncoding -> IO ()
IO.hSetEncoding Handle
h TextEncoding
IO.utf8
    -- Write a file which is portable between systems.
    Handle -> NewlineMode -> IO ()
IO.hSetNewlineMode Handle
h NewlineMode
IO.noNewlineTranslation
    Handle -> String -> IO ()
IO.hPutStr Handle
h String
contents
    Handle -> IO ()
IO.hClose Handle
h