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 { bellStyle :: !BellStyle,
editMode :: !EditMode,
maxHistorySize :: !(Maybe Int),
historyDuplicates :: HistoryDuplicates,
completionType :: !CompletionType,
completionPaging :: !Bool,
completionPromptLimit :: !(Maybe Int),
listCompletionsImmediately :: !Bool,
customBindings :: Map.Map Key [Key],
customKeySequences :: [(Maybe String, String,Key)]
}
deriving Show
data CompletionType = ListCompletion | MenuCompletion
deriving (Read,Show)
data BellStyle = NoBell | VisualBell | AudibleBell
deriving (Show, Read)
data EditMode = Vi | Emacs
deriving (Show,Read)
data HistoryDuplicates = AlwaysAdd | IgnoreConsecutive | IgnoreAll
deriving (Show,Read)
defaultPrefs :: Prefs
defaultPrefs = Prefs {bellStyle = AudibleBell,
maxHistorySize = Just 100,
editMode = Emacs,
completionType = ListCompletion,
completionPaging = True,
completionPromptLimit = Just 100,
listCompletionsImmediately = True,
historyDuplicates = AlwaysAdd,
customBindings = Map.empty,
customKeySequences = []
}
mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs
mkSettor f str = maybe id f (readMaybe str)
readMaybe :: Read a => String -> Maybe a
readMaybe str = case reads str of
[(x,_)] -> Just x
_ -> Nothing
settors :: [(String, String -> Prefs -> Prefs)]
settors = [("bellstyle", mkSettor $ \x p -> p {bellStyle = x})
,("editmode", mkSettor $ \x p -> p {editMode = x})
,("maxhistorysize", mkSettor $ \x p -> p {maxHistorySize = x})
,("completiontype", mkSettor $ \x p -> p {completionType = x})
,("completionpaging", mkSettor $ \x p -> p {completionPaging = x})
,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x})
,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x})
,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x})
,("bind", addCustomBinding)
,("keyseq", addCustomKeySequence)
]
addCustomBinding :: String -> Prefs -> Prefs
addCustomBinding str p = case mapM parseKey (words str) of
Just (k:ks) -> p {customBindings = Map.insert k ks (customBindings p)}
_ -> p
addCustomKeySequence :: String -> Prefs -> Prefs
addCustomKeySequence str = maybe id addKS maybeParse
where
maybeParse :: Maybe (Maybe String, String,Key)
maybeParse = case words str of
[cstr,kstr] -> parseWords Nothing cstr kstr
[term,cstr,kstr] -> parseWords (Just term) cstr kstr
_ -> Nothing
parseWords mterm cstr kstr = do
k <- parseKey kstr
cs <- readMaybe cstr
return (mterm,cs,k)
addKS ks p = p {customKeySequences = ks:customKeySequences p}
lookupKeyBinding :: Key -> Prefs -> [Key]
lookupKeyBinding k = Map.findWithDefault [k] k . customBindings
readPrefs :: FilePath -> IO Prefs
readPrefs file = handle (\(_::IOException) -> return defaultPrefs) $ do
ls <- fmap lines $ readFile file
return $! foldl' applyField defaultPrefs ls
where
applyField p l = case break (==':') l of
(name,val) -> case lookup (map toLower $ trimSpaces name) settors of
Nothing -> p
Just set -> set (drop 1 val) p
trimSpaces = dropWhile isSpace . reverse . dropWhile isSpace . reverse