module System.Console.Haskeline.Prefs(
                        Prefs(..),
                        defaultPrefs,
                        readPrefs,
                        CompletionType(..),
                        BellStyle(..),
                        EditMode(..),
                        HistoryDuplicates(..),
                        lookupKeyBinding
                        ) where

import Control.Monad.Catch (handle)
import Control.Exception (IOException)
import Data.Char(isSpace,toLower)
import Data.List(foldl')
import qualified Data.Map as Map
import System.Console.Haskeline.Key

{- |
'Prefs' allow the user to customize the terminal-style line-editing interface.  They are
read by default from @~/.haskeline@; to override that behavior, use
'readPrefs' and @runInputTWithPrefs@.

Each line of a @.haskeline@ file defines
one field of the 'Prefs' datatype; field names are case-insensitive and
unparseable lines are ignored.  For example:

> editMode: Vi
> completionType: MenuCompletion
> maxhistorysize: Just 40

-}
data Prefs = Prefs { Prefs -> BellStyle
bellStyle :: !BellStyle,
                     Prefs -> EditMode
editMode :: !EditMode,
                     Prefs -> Maybe Int
maxHistorySize :: !(Maybe Int),
                     Prefs -> HistoryDuplicates
historyDuplicates :: HistoryDuplicates,
                     Prefs -> CompletionType
completionType :: !CompletionType,
                     Prefs -> Bool
completionPaging :: !Bool, 
                        -- ^ When listing completion alternatives, only display
                        -- one screen of possibilities at a time.
                     Prefs -> Maybe Int
completionPromptLimit :: !(Maybe Int),
                        -- ^ If more than this number of completion
                        -- possibilities are found, then ask before listing
                        -- them.
                     Prefs -> Bool
listCompletionsImmediately :: !Bool,
                        -- ^ If 'False', completions with multiple possibilities
                        -- will ring the bell and only display them if the user
                        -- presses @TAB@ again.
                     Prefs -> Map Key [Key]
customBindings :: Map.Map Key [Key],
                        -- (termName, keysequence, key)
                     Prefs -> [(Maybe String, String, Key)]
customKeySequences :: [(Maybe String, String,Key)]
                     }
                        deriving Int -> Prefs -> ShowS
[Prefs] -> ShowS
Prefs -> String
(Int -> Prefs -> ShowS)
-> (Prefs -> String) -> ([Prefs] -> ShowS) -> Show Prefs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prefs] -> ShowS
$cshowList :: [Prefs] -> ShowS
show :: Prefs -> String
$cshow :: Prefs -> String
showsPrec :: Int -> Prefs -> ShowS
$cshowsPrec :: Int -> Prefs -> ShowS
Show

data CompletionType = ListCompletion | MenuCompletion
            deriving (ReadPrec [CompletionType]
ReadPrec CompletionType
Int -> ReadS CompletionType
ReadS [CompletionType]
(Int -> ReadS CompletionType)
-> ReadS [CompletionType]
-> ReadPrec CompletionType
-> ReadPrec [CompletionType]
-> Read CompletionType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CompletionType]
$creadListPrec :: ReadPrec [CompletionType]
readPrec :: ReadPrec CompletionType
$creadPrec :: ReadPrec CompletionType
readList :: ReadS [CompletionType]
$creadList :: ReadS [CompletionType]
readsPrec :: Int -> ReadS CompletionType
$creadsPrec :: Int -> ReadS CompletionType
Read,Int -> CompletionType -> ShowS
[CompletionType] -> ShowS
CompletionType -> String
(Int -> CompletionType -> ShowS)
-> (CompletionType -> String)
-> ([CompletionType] -> ShowS)
-> Show CompletionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompletionType] -> ShowS
$cshowList :: [CompletionType] -> ShowS
show :: CompletionType -> String
$cshow :: CompletionType -> String
showsPrec :: Int -> CompletionType -> ShowS
$cshowsPrec :: Int -> CompletionType -> ShowS
Show)


data BellStyle = NoBell | VisualBell | AudibleBell
                    deriving (Int -> BellStyle -> ShowS
[BellStyle] -> ShowS
BellStyle -> String
(Int -> BellStyle -> ShowS)
-> (BellStyle -> String)
-> ([BellStyle] -> ShowS)
-> Show BellStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BellStyle] -> ShowS
$cshowList :: [BellStyle] -> ShowS
show :: BellStyle -> String
$cshow :: BellStyle -> String
showsPrec :: Int -> BellStyle -> ShowS
$cshowsPrec :: Int -> BellStyle -> ShowS
Show, ReadPrec [BellStyle]
ReadPrec BellStyle
Int -> ReadS BellStyle
ReadS [BellStyle]
(Int -> ReadS BellStyle)
-> ReadS [BellStyle]
-> ReadPrec BellStyle
-> ReadPrec [BellStyle]
-> Read BellStyle
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BellStyle]
$creadListPrec :: ReadPrec [BellStyle]
readPrec :: ReadPrec BellStyle
$creadPrec :: ReadPrec BellStyle
readList :: ReadS [BellStyle]
$creadList :: ReadS [BellStyle]
readsPrec :: Int -> ReadS BellStyle
$creadsPrec :: Int -> ReadS BellStyle
Read)

data EditMode = Vi | Emacs
                    deriving (Int -> EditMode -> ShowS
[EditMode] -> ShowS
EditMode -> String
(Int -> EditMode -> ShowS)
-> (EditMode -> String) -> ([EditMode] -> ShowS) -> Show EditMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditMode] -> ShowS
$cshowList :: [EditMode] -> ShowS
show :: EditMode -> String
$cshow :: EditMode -> String
showsPrec :: Int -> EditMode -> ShowS
$cshowsPrec :: Int -> EditMode -> ShowS
Show,ReadPrec [EditMode]
ReadPrec EditMode
Int -> ReadS EditMode
ReadS [EditMode]
(Int -> ReadS EditMode)
-> ReadS [EditMode]
-> ReadPrec EditMode
-> ReadPrec [EditMode]
-> Read EditMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EditMode]
$creadListPrec :: ReadPrec [EditMode]
readPrec :: ReadPrec EditMode
$creadPrec :: ReadPrec EditMode
readList :: ReadS [EditMode]
$creadList :: ReadS [EditMode]
readsPrec :: Int -> ReadS EditMode
$creadsPrec :: Int -> ReadS EditMode
Read)

data HistoryDuplicates = AlwaysAdd | IgnoreConsecutive | IgnoreAll
                    deriving (Int -> HistoryDuplicates -> ShowS
[HistoryDuplicates] -> ShowS
HistoryDuplicates -> String
(Int -> HistoryDuplicates -> ShowS)
-> (HistoryDuplicates -> String)
-> ([HistoryDuplicates] -> ShowS)
-> Show HistoryDuplicates
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HistoryDuplicates] -> ShowS
$cshowList :: [HistoryDuplicates] -> ShowS
show :: HistoryDuplicates -> String
$cshow :: HistoryDuplicates -> String
showsPrec :: Int -> HistoryDuplicates -> ShowS
$cshowsPrec :: Int -> HistoryDuplicates -> ShowS
Show,ReadPrec [HistoryDuplicates]
ReadPrec HistoryDuplicates
Int -> ReadS HistoryDuplicates
ReadS [HistoryDuplicates]
(Int -> ReadS HistoryDuplicates)
-> ReadS [HistoryDuplicates]
-> ReadPrec HistoryDuplicates
-> ReadPrec [HistoryDuplicates]
-> Read HistoryDuplicates
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HistoryDuplicates]
$creadListPrec :: ReadPrec [HistoryDuplicates]
readPrec :: ReadPrec HistoryDuplicates
$creadPrec :: ReadPrec HistoryDuplicates
readList :: ReadS [HistoryDuplicates]
$creadList :: ReadS [HistoryDuplicates]
readsPrec :: Int -> ReadS HistoryDuplicates
$creadsPrec :: Int -> ReadS HistoryDuplicates
Read)

-- | The default preferences which may be overwritten in the
-- @.haskeline@ file.
defaultPrefs :: Prefs
defaultPrefs :: Prefs
defaultPrefs = Prefs :: BellStyle
-> EditMode
-> Maybe Int
-> HistoryDuplicates
-> CompletionType
-> Bool
-> Maybe Int
-> Bool
-> Map Key [Key]
-> [(Maybe String, String, Key)]
-> Prefs
Prefs {bellStyle :: BellStyle
bellStyle = BellStyle
AudibleBell,
                      maxHistorySize :: Maybe Int
maxHistorySize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
100,
                      editMode :: EditMode
editMode = EditMode
Emacs,
                      completionType :: CompletionType
completionType = CompletionType
ListCompletion,
                      completionPaging :: Bool
completionPaging = Bool
True,
                      completionPromptLimit :: Maybe Int
completionPromptLimit = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
100,
                      listCompletionsImmediately :: Bool
listCompletionsImmediately = Bool
True,
                      historyDuplicates :: HistoryDuplicates
historyDuplicates = HistoryDuplicates
AlwaysAdd,
                      customBindings :: Map Key [Key]
customBindings = Map Key [Key]
forall k a. Map k a
Map.empty,
                      customKeySequences :: [(Maybe String, String, Key)]
customKeySequences = []
                    }

mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor :: (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor a -> Prefs -> Prefs
f String
str = (Prefs -> Prefs)
-> (a -> Prefs -> Prefs) -> Maybe a -> Prefs -> Prefs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Prefs -> Prefs
forall a. a -> a
id a -> Prefs -> Prefs
f (String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str)

readMaybe :: Read a => String -> Maybe a
readMaybe :: String -> Maybe a
readMaybe String
str = case ReadS a
forall a. Read a => ReadS a
reads String
str of
                [(a
x,String
_)] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
                [(a, String)]
_ -> Maybe a
forall a. Maybe a
Nothing


settors :: [(String, String -> Prefs -> Prefs)]
settors :: [(String, String -> Prefs -> Prefs)]
settors = [(String
"bellstyle", (BellStyle -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((BellStyle -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (BellStyle -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \BellStyle
x Prefs
p -> Prefs
p {bellStyle :: BellStyle
bellStyle = BellStyle
x})
          ,(String
"editmode", (EditMode -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((EditMode -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (EditMode -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \EditMode
x Prefs
p -> Prefs
p {editMode :: EditMode
editMode = EditMode
x})
          ,(String
"maxhistorysize", (Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \Maybe Int
x Prefs
p -> Prefs
p {maxHistorySize :: Maybe Int
maxHistorySize = Maybe Int
x})
          ,(String
"completiontype", (CompletionType -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((CompletionType -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (CompletionType -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \CompletionType
x Prefs
p -> Prefs
p {completionType :: CompletionType
completionType = CompletionType
x})
          ,(String
"completionpaging", (Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \Bool
x Prefs
p -> Prefs
p {completionPaging :: Bool
completionPaging = Bool
x})
          ,(String
"completionpromptlimit", (Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (Maybe Int -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \Maybe Int
x Prefs
p -> Prefs
p {completionPromptLimit :: Maybe Int
completionPromptLimit = Maybe Int
x})
          ,(String
"listcompletionsimmediately", (Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (Bool -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a b. (a -> b) -> a -> b
$ \Bool
x Prefs
p -> Prefs
p {listCompletionsImmediately :: Bool
listCompletionsImmediately = Bool
x})
          ,(String
"historyduplicates", (HistoryDuplicates -> Prefs -> Prefs) -> String -> Prefs -> Prefs
forall a.
Read a =>
(a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor ((HistoryDuplicates -> Prefs -> Prefs) -> String -> Prefs -> Prefs)
-> (HistoryDuplicates -> Prefs -> Prefs)
-> String
-> Prefs
-> Prefs
forall a b. (a -> b) -> a -> b
$ \HistoryDuplicates
x Prefs
p -> Prefs
p {historyDuplicates :: HistoryDuplicates
historyDuplicates = HistoryDuplicates
x})
          ,(String
"bind", String -> Prefs -> Prefs
addCustomBinding)
          ,(String
"keyseq", String -> Prefs -> Prefs
addCustomKeySequence)
          ]

addCustomBinding :: String -> Prefs -> Prefs
addCustomBinding :: String -> Prefs -> Prefs
addCustomBinding String
str Prefs
p = case (String -> Maybe Key) -> [String] -> Maybe [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Maybe Key
parseKey (String -> [String]
words String
str) of
    Just (Key
k:[Key]
ks) -> Prefs
p {customBindings :: Map Key [Key]
customBindings = Key -> [Key] -> Map Key [Key] -> Map Key [Key]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
k [Key]
ks (Prefs -> Map Key [Key]
customBindings Prefs
p)}
    Maybe [Key]
_ -> Prefs
p

addCustomKeySequence :: String -> Prefs -> Prefs
addCustomKeySequence :: String -> Prefs -> Prefs
addCustomKeySequence String
str = (Prefs -> Prefs)
-> ((Maybe String, String, Key) -> Prefs -> Prefs)
-> Maybe (Maybe String, String, Key)
-> Prefs
-> Prefs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Prefs -> Prefs
forall a. a -> a
id (Maybe String, String, Key) -> Prefs -> Prefs
addKS Maybe (Maybe String, String, Key)
maybeParse
    where
        maybeParse :: Maybe (Maybe String, String,Key)
        maybeParse :: Maybe (Maybe String, String, Key)
maybeParse = case String -> [String]
words String
str of
            [String
cstr,String
kstr] -> Maybe String
-> String -> String -> Maybe (Maybe String, String, Key)
forall b a. Read b => a -> String -> String -> Maybe (a, b, Key)
parseWords Maybe String
forall a. Maybe a
Nothing String
cstr String
kstr
            [String
term,String
cstr,String
kstr] -> Maybe String
-> String -> String -> Maybe (Maybe String, String, Key)
forall b a. Read b => a -> String -> String -> Maybe (a, b, Key)
parseWords (String -> Maybe String
forall a. a -> Maybe a
Just String
term) String
cstr String
kstr
            [String]
_ -> Maybe (Maybe String, String, Key)
forall a. Maybe a
Nothing
        parseWords :: a -> String -> String -> Maybe (a, b, Key)
parseWords a
mterm String
cstr String
kstr = do
            Key
k <- String -> Maybe Key
parseKey String
kstr
            b
cs <- String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe String
cstr
            (a, b, Key) -> Maybe (a, b, Key)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
mterm,b
cs,Key
k)
        addKS :: (Maybe String, String, Key) -> Prefs -> Prefs
addKS (Maybe String, String, Key)
ks Prefs
p = Prefs
p {customKeySequences :: [(Maybe String, String, Key)]
customKeySequences = (Maybe String, String, Key)
ks(Maybe String, String, Key)
-> [(Maybe String, String, Key)] -> [(Maybe String, String, Key)]
forall a. a -> [a] -> [a]
:Prefs -> [(Maybe String, String, Key)]
customKeySequences Prefs
p}

lookupKeyBinding :: Key -> Prefs -> [Key]
lookupKeyBinding :: Key -> Prefs -> [Key]
lookupKeyBinding Key
k = [Key] -> Key -> Map Key [Key] -> [Key]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [Key
k] Key
k (Map Key [Key] -> [Key])
-> (Prefs -> Map Key [Key]) -> Prefs -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prefs -> Map Key [Key]
customBindings

-- | Read 'Prefs' from a given file.  If there is an error reading the file,
-- the 'defaultPrefs' will be returned.
readPrefs :: FilePath -> IO Prefs
readPrefs :: String -> IO Prefs
readPrefs String
file = (IOException -> IO Prefs) -> IO Prefs -> IO Prefs
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> Prefs -> IO Prefs
forall (m :: * -> *) a. Monad m => a -> m a
return Prefs
defaultPrefs) (IO Prefs -> IO Prefs) -> IO Prefs -> IO Prefs
forall a b. (a -> b) -> a -> b
$ do
    [String]
ls <- (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
file
    Prefs -> IO Prefs
forall (m :: * -> *) a. Monad m => a -> m a
return (Prefs -> IO Prefs) -> Prefs -> IO Prefs
forall a b. (a -> b) -> a -> b
$! (Prefs -> String -> Prefs) -> Prefs -> [String] -> Prefs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Prefs -> String -> Prefs
applyField Prefs
defaultPrefs [String]
ls
  where
    applyField :: Prefs -> String -> Prefs
applyField Prefs
p String
l = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
l of
                (String
name,String
val)  -> case String
-> [(String, String -> Prefs -> Prefs)]
-> Maybe (String -> Prefs -> Prefs)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
trimSpaces String
name) [(String, String -> Prefs -> Prefs)]
settors of
                        Maybe (String -> Prefs -> Prefs)
Nothing -> Prefs
p
                        Just String -> Prefs -> Prefs
set -> String -> Prefs -> Prefs
set (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
val) Prefs
p  -- drop initial ":", don't crash if val==""
    trimSpaces :: ShowS
trimSpaces = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse