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 Control.Applicative
import Control.Monad
import Control.Lens hiding (act)
import Data.List (isInfixOf)
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.String (IsString)
import Data.Typeable
import Data.Foldable (find)
import Yi.Config
import Yi.Core
import Yi.History
import Yi.Completion (infixMatch, prefixMatch, containsMatch', completeInList, completeInList')
import Yi.Style (defaultStyle)
import Yi.Utils
import Yi.Monad
import qualified Data.Rope as R
import System.CanonicalizePath (replaceShorthands)
spawnMinibufferE :: String -> KeymapEndo -> EditorM BufferRef
spawnMinibufferE prompt kmMod =
do b <- stringToNewBuffer (Left prompt) (R.fromString "")
withGivenBuffer0 b $
modifyMode $ \m -> m { modeKeymap = \kms -> kms { topKeymap = kmMod (insertKeymap kms)
, startTopKeymap = kmMod (startInsertKeymap kms)
} }
w <- newWindowE True b
(%=) windowsA (PL.insertRight w)
return b
withMinibuffer :: String -> (String -> YiM [String]) -> (String -> YiM ()) -> YiM ()
withMinibuffer prompt getPossibilities act =
withMinibufferGen "" giveHint prompt completer (const $ return ()) 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 (const $ return ())
withMinibufferGen :: String -> (String -> YiM [String]) -> String
-> (String -> YiM String) -> (String -> YiM ())
-> (String -> YiM ()) -> YiM ()
withMinibufferGen proposal getHint prompt completer onTyping act = do
initialBuffer <- gets currentBuffer
initialWindow <- use currentWindowA
let innerAction :: YiM ()
closeMinibuffer = closeBufferAndWindowE >>
(%=) windowsA (fromJust . PL.find initialWindow)
showMatchings = showMatchingsOf =<< withBuffer elemsB
showMatchingsOf userInput =
withEditor . printStatus =<< fmap withDefaultStyle (getHint userInput)
withDefaultStyle msg = (msg, defaultStyle)
typing = onTyping =<< withBuffer elemsB
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
void $ spawnMinibufferE (prompt ++ " ")
(\bindings -> rebindings <|| (bindings >> write showMatchings
>> write typing))
withBuffer0 $ replaceBufferContent (replaceShorthands proposal)
withMinibufferFin :: String -> [String] -> (String -> YiM ()) -> YiM ()
withMinibufferFin prompt possibilities act
= withMinibufferGen "" hinter prompt completer
(const $ return ()) (act . best)
where
hinter s = return $ match s
match s = filter (s `isInfixOf`) possibilities
best s
| s `elem` 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 ++ ":") (act <=< getPromptedValue)
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 null x 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 = withMinibufferFin prompt (fmap fst vs)
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"