module Yi.MiniBuffer
(
spawnMinibufferE,
withMinibufferFree, withMinibuffer, withMinibufferGen, withMinibufferFin,
noHint, noPossibilities, mkCompleteFn, simpleComplete, infixComplete, infixComplete', anyModeByName, getAllModeNames,
matchingBufferNames, anyModeByNameM, anyModeName,
(:::)(..),
LineNumber, RegexTag, FilePatternTag, ToKill,
CommandArguments(..)
) where
import Prelude (filter, length, words)
import Data.List (isInfixOf)
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.String (IsString)
import Yi.Config
import Yi.Core
import Yi.History
import Yi.Completion (infixMatch, prefixMatch, containsMatch', completeInList, completeInList')
import Yi.Style (defaultStyle)
import qualified Data.Rope as R
spawnMinibufferE :: String -> KeymapEndo -> EditorM BufferRef
spawnMinibufferE prompt kmMod =
do b <- stringToNewBuffer (Left prompt) (R.fromString "")
withGivenBuffer0 b $ do
modifyMode $ \m -> m { modeKeymap = \kms -> kms { topKeymap = kmMod (insertKeymap kms)
, startTopKeymap = kmMod (startInsertKeymap kms)
} }
w <- newWindowE True b
modA windowsA (PL.insertRight w)
return b
withMinibuffer :: String -> (String -> YiM [String]) -> (String -> YiM ()) -> YiM ()
withMinibuffer prompt getPossibilities act =
withMinibufferGen "" giveHint prompt completer act
where giveHint s = catMaybes . fmap (prefixMatch s) <$> getPossibilities s
completer = simpleComplete getPossibilities
mkCompleteFn :: (String -> (String -> Maybe String) -> [String] -> EditorM String) ->
(String -> String -> Maybe String) -> (String -> YiM [String]) -> String -> YiM String
mkCompleteFn completeInListFn match getPossibilities s = do
possibles <- getPossibilities s
withEditor $ completeInListFn s (match s) possibles
simpleComplete :: (String -> YiM [String]) -> String -> YiM String
simpleComplete = mkCompleteFn completeInList prefixMatch
infixComplete' :: Bool -> (String -> YiM [String]) -> String -> YiM String
infixComplete' caseSensitive = mkCompleteFn completeInList' $ containsMatch' caseSensitive
infixComplete :: (String -> YiM [String]) -> String -> YiM String
infixComplete = infixComplete' True
noHint :: String -> YiM [String]
noHint = const $ return []
noPossibilities :: String -> YiM [ String ]
noPossibilities _s = return []
withMinibufferFree :: String -> (String -> YiM ()) -> YiM ()
withMinibufferFree prompt = withMinibufferGen "" noHint prompt return
withMinibufferGen :: String -> (String -> YiM [String]) ->
String -> (String -> YiM String) -> (String -> YiM ()) -> YiM ()
withMinibufferGen proposal getHint prompt completer act = do
initialBuffer <- gets currentBuffer
initialWindow <- getA currentWindowA
let innerAction :: YiM ()
closeMinibuffer = closeBufferAndWindowE >>
modA windowsA (fromJust . PL.find initialWindow)
showMatchings = showMatchingsOf =<< withBuffer elemsB
showMatchingsOf userInput = withEditor . printStatus =<< fmap withDefaultStyle (getHint userInput)
withDefaultStyle msg = (msg, defaultStyle)
innerAction = do
lineString <- withEditor $ do historyFinishGen prompt (withBuffer0 elemsB)
lineString <- withBuffer0 elemsB
closeMinibuffer
switchToBufferE initialBuffer
return lineString
act lineString
up = historyMove prompt 1
down = historyMove prompt (1)
rebindings = choice [oneOf [spec KEnter, ctrl $ char 'm'] >>! innerAction,
oneOf [spec KUp, meta $ char 'p'] >>! up,
oneOf [spec KDown, meta $ char 'n'] >>! down,
oneOf [spec KTab, ctrl $ char 'i'] >>! completionFunction completer >>! showMatchings,
ctrl (char 'g') ?>>! closeMinibuffer]
showMatchingsOf ""
withEditor $ do
historyStartGen prompt
discard $ spawnMinibufferE (prompt ++ " ") (\bindings -> rebindings <|| (bindings >> write showMatchings))
withBuffer0 $ replaceBufferContent proposal
withMinibufferFin :: String -> [String] -> (String -> YiM ()) -> YiM ()
withMinibufferFin prompt possibilities act
= withMinibufferGen "" hinter prompt completer (act . best)
where
hinter s = return $ match s
match s = filter (s `isInfixOf`) possibilities
best s
| any (== s) matches = s
| null matches = s
| otherwise = head matches
where matches = match s
completer s = return $ case commonPrefix $ catMaybes $ fmap (infixMatch s) possibilities of
"" -> s
p -> p
completionFunction :: (String -> YiM String) -> YiM ()
completionFunction f = do
p <- withBuffer pointB
let r = mkRegion 0 p
text <- withBuffer $ readRegionB r
compl <- f text
withBuffer $ replaceRegionB r compl
class Promptable a where
getPromptedValue :: String -> YiM a
getPrompt :: a -> String
getMinibuffer :: a -> String -> (String -> YiM ()) -> YiM ()
getMinibuffer _ = withMinibufferFree
doPrompt :: forall a. Promptable a => (a -> YiM ()) -> YiM ()
doPrompt act = getMinibuffer witness (getPrompt witness ++ ":") $
\string -> act =<< getPromptedValue string
where witness = error "Promptable argument should not be accessed"
witness :: a
instance Promptable String where
getPromptedValue = return
getPrompt _ = "String"
instance Promptable Char where
getPromptedValue x = if length x == 0 then error "Please supply a character."
else return $ head x
getPrompt _ = "Char"
instance Promptable Int where
getPromptedValue = return . read
getPrompt _ = "Integer"
getPromptedValueList :: [(String,a)] -> String -> YiM a
getPromptedValueList vs s = maybe (error "Invalid choice") return (lookup s vs)
getMinibufferList :: [(String,a)] -> a -> String -> (String -> YiM ()) -> YiM ()
getMinibufferList vs _ prompt act = withMinibufferFin prompt (fmap fst vs) act
enumAll :: (Enum a, Bounded a, Show a) => [(String, a)]
enumAll = (fmap (\v -> (show v, v)) [minBound..])
instance Promptable Direction where
getPromptedValue = getPromptedValueList enumAll
getPrompt _ = "Direction"
getMinibuffer = getMinibufferList enumAll
textUnits :: [(String, TextUnit)]
textUnits =
[("Character", Character),
("Document", Document),
("Line", Line),
("Paragraph", unitParagraph),
("Word", unitWord),
("ViWord", unitViWord)
]
instance Promptable TextUnit where
getPromptedValue = getPromptedValueList textUnits
getPrompt _ = "Unit"
getMinibuffer = getMinibufferList textUnits
instance Promptable Point where
getPromptedValue s = Point <$> getPromptedValue s
getPrompt _ = "Point"
anyModeName :: AnyMode -> String
anyModeName (AnyMode m) = modeName m
anyModeByNameM :: String -> YiM (Maybe AnyMode)
anyModeByNameM n = find ((n==) . anyModeName) . modeTable <$> askCfg
anyModeByName :: String -> YiM AnyMode
anyModeByName n = maybe (fail "no such mode") return =<< anyModeByNameM n
getAllModeNames :: YiM [String]
getAllModeNames = fmap anyModeName . modeTable <$> askCfg
instance Promptable AnyMode where
getPrompt _ = "Mode"
getPromptedValue = anyModeByName
getMinibuffer _ prompt act = do
names <- getAllModeNames
withMinibufferFin prompt names act
instance Promptable BufferRef where
getPrompt _ = "Buffer"
getPromptedValue = withEditor . getBufferWithNameOrCurrent
getMinibuffer _ prompt act = do
bufs <- matchingBufferNames ""
withMinibufferFin prompt bufs act
matchingBufferNames :: String -> YiM [String]
matchingBufferNames _ = withEditor $ do
p <- gets commonNamePrefix
bs <- gets bufferSet
return $ fmap (shortIdentString p) bs
instance (YiAction a x, Promptable r) => YiAction (r -> a) x where
makeAction f = YiA $ doPrompt (runAction . makeAction . f)
newtype (:::) t doc = Doc {fromDoc :: t} deriving (Eq, Typeable, Num, IsString)
instance Show x => Show (x ::: t) where
show (Doc d) = show d
instance (DocType doc, Promptable t) => Promptable (t ::: doc) where
getPrompt _ = typeGetPrompt (error "typeGetPrompt should not enter its argument" :: doc)
getPromptedValue x = Doc <$> getPromptedValue x
class DocType t where
typeGetPrompt :: t -> String
data LineNumber
instance DocType LineNumber where
typeGetPrompt _ = "Line"
data ToKill
instance DocType ToKill where
typeGetPrompt _ = "kill buffer"
data RegexTag deriving Typeable
instance DocType RegexTag where
typeGetPrompt _ = "Regex"
data FilePatternTag deriving Typeable
instance DocType FilePatternTag where
typeGetPrompt _ = "File pattern"
newtype CommandArguments = CommandArguments [String]
deriving Typeable
instance Promptable CommandArguments where
getPromptedValue = return . CommandArguments . words
getPrompt _ = "Command arguments"