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
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,
Prefs -> Maybe Int
completionPromptLimit :: !(Maybe Int),
Prefs -> Bool
listCompletionsImmediately :: !Bool,
Prefs -> Map Key [Key]
customBindings :: Map.Map Key [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
$cshowsPrec :: Int -> Prefs -> ShowS
showsPrec :: Int -> Prefs -> ShowS
$cshow :: Prefs -> String
show :: Prefs -> String
$cshowList :: [Prefs] -> ShowS
showList :: [Prefs] -> ShowS
Show
data CompletionType = ListCompletion |
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
$creadsPrec :: Int -> ReadS CompletionType
readsPrec :: Int -> ReadS CompletionType
$creadList :: ReadS [CompletionType]
readList :: ReadS [CompletionType]
$creadPrec :: ReadPrec CompletionType
readPrec :: ReadPrec CompletionType
$creadListPrec :: ReadPrec [CompletionType]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> CompletionType -> ShowS
showsPrec :: Int -> CompletionType -> ShowS
$cshow :: CompletionType -> String
show :: CompletionType -> String
$cshowList :: [CompletionType] -> ShowS
showList :: [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
$cshowsPrec :: Int -> BellStyle -> ShowS
showsPrec :: Int -> BellStyle -> ShowS
$cshow :: BellStyle -> String
show :: BellStyle -> String
$cshowList :: [BellStyle] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS BellStyle
readsPrec :: Int -> ReadS BellStyle
$creadList :: ReadS [BellStyle]
readList :: ReadS [BellStyle]
$creadPrec :: ReadPrec BellStyle
readPrec :: ReadPrec BellStyle
$creadListPrec :: ReadPrec [BellStyle]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> EditMode -> ShowS
showsPrec :: Int -> EditMode -> ShowS
$cshow :: EditMode -> String
show :: EditMode -> String
$cshowList :: [EditMode] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS EditMode
readsPrec :: Int -> ReadS EditMode
$creadList :: ReadS [EditMode]
readList :: ReadS [EditMode]
$creadPrec :: ReadPrec EditMode
readPrec :: ReadPrec EditMode
$creadListPrec :: ReadPrec [EditMode]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> HistoryDuplicates -> ShowS
showsPrec :: Int -> HistoryDuplicates -> ShowS
$cshow :: HistoryDuplicates -> String
show :: HistoryDuplicates -> String
$cshowList :: [HistoryDuplicates] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS HistoryDuplicates
readsPrec :: Int -> ReadS HistoryDuplicates
$creadList :: ReadS [HistoryDuplicates]
readList :: ReadS [HistoryDuplicates]
$creadPrec :: ReadPrec HistoryDuplicates
readPrec :: ReadPrec HistoryDuplicates
$creadListPrec :: ReadPrec [HistoryDuplicates]
readListPrec :: ReadPrec [HistoryDuplicates]
Read)
defaultPrefs :: Prefs
defaultPrefs :: Prefs
defaultPrefs = 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 :: forall a.
Read a =>
(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 :: forall a. Read a => 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> Maybe a
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
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 a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
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 b a. (b -> a -> b) -> b -> [a] -> b
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
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