yi-core-0.19.4/0000755000000000000000000000000007346545000011345 5ustar0000000000000000yi-core-0.19.4/Setup.hs0000644000000000000000000000012607346545000013000 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main :: IO () main = defaultMain yi-core-0.19.4/bench/0000755000000000000000000000000007346545000012424 5ustar0000000000000000yi-core-0.19.4/bench/Bench.hs0000644000000000000000000000577107346545000014011 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import Control.DeepSeq import Control.Monad import Criterion import Criterion.Main hiding (defaultConfig) import qualified Data.List as L import System.Environment import System.IO import Text.Printf (printf) import Yi.Buffer import Yi.Config (Config) import Yi.Config.Default (defaultConfig) import Yi.Editor import qualified Yi.Rope as R -- bogus instance instance NFData Editor where rnf !_ = () data EditorAction = forall a b. (NFData a, NFData b) => EditorAction { _ea_act :: b -> EditorM a , _ea_report :: a -> IO () , _ea_setup :: EditorM b , _ea_name :: String , _ea_config :: Config } simpleAction :: String -> EditorM () -> EditorAction simpleAction n act = EditorAction { _ea_act = \() -> act , _ea_report = \() -> return () , _ea_name = n , _ea_config = defaultConfig , _ea_setup = return () } insertN :: Int -> EditorAction insertN !n = EditorAction { _ea_act = \() -> do runLoop , _ea_report = \yis_l -> putStrLn $ printf "Buffer has %d characters." yis_l , _ea_name = "insert" ++ show n , _ea_config = defaultConfig , _ea_setup = return () } where spin n' | n' <= 0 = R.length <$> elemsB | otherwise = do insertB 'X' spin $! n' - 1 runLoop = withCurrentBuffer $ spin n acts :: [EditorAction] acts = [ simpleAction "split20" $ replicateM_ 20 splitE , simpleAction "newTab20" (replicateM_ 20 newTabE) , Main.insertN 10 , Main.insertN 100 , Main.insertN 1000 , Main.insertN 100000 , Main.insertN 1000000 ] benchEditor :: (NFData a, NFData b) => String -- ^ Benchmark name -> Config -- ^ Config -> EditorM a -- ^ Setup -> (a -> EditorM b) -- ^ Action -> Benchmark benchEditor bname c setup act = env (return $! runEditor c setup emptyEditor) $ \ ~(setupEditor, a) -> do bench bname $ nf (\a' -> snd $ runEditor c (act a') setupEditor) a main :: IO () main = getArgs >>= \case ["list_actions"] -> print $ map _ea_name acts ["run_action", action_name] -> case L.find ((action_name ==) . _ea_name) acts of Just EditorAction{..} -> let !(!_, b) = runEditor _ea_config (_ea_setup >>= _ea_act) emptyEditor in do _ea_report b putStrLn $ _ea_name ++ " finished." _ -> do hPutStrLn stderr $ "No such action: " ++ action_name hPutStrLn stderr $ "Available actions: " ++ show (map _ea_name acts) _ -> do let benchmarks :: [Benchmark] benchmarks = flip map acts $ \EditorAction{..} -> benchEditor _ea_name _ea_config _ea_setup _ea_act defaultMain benchmarks yi-core-0.19.4/src/Control/0000755000000000000000000000000007346545000013554 5ustar0000000000000000yi-core-0.19.4/src/Control/Exc.hs0000644000000000000000000000156507346545000014636 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | Utilities for working with new Control.Exception module Control.Exc (ignoringException, printingException, orException) where import Prelude import Control.Exception (catch, SomeException) -- | Execute IO (Maybe a) action replacing all exceptions with return value of Nothing. ignoringException :: IO (Maybe a) -> IO (Maybe a) ignoringException f = f `catch` ignore where ignore (_ :: SomeException) = return Nothing -- | Execute IO () action, replacing all exceptions with messages printingException :: String -> IO a -> IO a printingException desc f = f `catch` handler where handler (err :: SomeException) = fail $ concat [desc, " failed: ", show err] -- | Execute IO () action, replacing all exceptions with messages orException :: IO a -> IO a -> IO a orException f g = f `catch` handler where handler (_ :: SomeException) = g yi-core-0.19.4/src/Data/0000755000000000000000000000000007346545000013005 5ustar0000000000000000yi-core-0.19.4/src/Data/DelayList.hs0000644000000000000000000000132407346545000015233 0ustar0000000000000000-- maybe use package event-list instead. module Data.DelayList (insert, decrease, DelayList) where type DelayList a = [(Int, a)] -- | Subtraction, but treat maxBound as infinity. i.e. maxBound -? x == maxBound (-?) :: Int -> Int -> Int x -? y | x == maxBound = x | otherwise = x - y insert :: (Int, a) -> DelayList a -> DelayList a insert (d, a) [] = [(d, a)] insert (d, a) l@(h@(d', _):t) | d == d' = (d, a):t | d < d' = (d, a) : decrease d l -- d > d' | otherwise = h : insert (d -? d', a) t decrease :: Int -> DelayList a -> DelayList a decrease _ [] = [] decrease d l@((d',a):t) | d <= 0 = l | d < d' = (d' -? d, a):t -- d >= d' | otherwise = decrease (d - d') t yi-core-0.19.4/src/Parser/0000755000000000000000000000000007346545000013370 5ustar0000000000000000yi-core-0.19.4/src/Parser/Incremental.hs0000644000000000000000000003344007346545000016171 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} -- TODO: -- better interface -- have error messages in the right order -- have a message for plain failures as well / remove failure in recoveries -- Optimize profile info (no more Ints) module Parser.Incremental (Process, recoverWith, symbol, eof, lookNext, testNext, run, mkProcess, profile, pushSyms, pushEof, evalL, evalR, feedZ, Parser(Look, Enter, Yuck), countWidth, fullLog, LogEntry(..), evalL' ) where import Control.Arrow (first, second, (***)) import Control.Applicative (Alternative ((<|>), empty)) import qualified Control.Monad.Fail as Fail import Data.Tree (Tree (Node)) data a :< b = (:<) {top :: a, _rest :: b} infixr :< -- | Parser specification data Parser s a where Pure :: a -> Parser s a Appl :: Parser s (b -> a) -> Parser s b -> Parser s a Bind :: Parser s a -> (a -> Parser s b) -> Parser s b Look :: Parser s a -> (s -> Parser s a) -> Parser s a Shif :: Parser s a -> Parser s a Empt :: Parser s a Disj :: Parser s a -> Parser s a -> Parser s a Yuck :: Parser s a -> Parser s a Enter :: String -> Parser s a -> Parser s a -- | Parser process data Steps s a where Val :: a -> Steps s r -> Steps s (a :< r) App :: Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r) Done :: Steps s () Shift :: Steps s a -> Steps s a Sh' :: Steps s a -> Steps s a Sus :: Steps s a -> (s -> Steps s a) -> Steps s a Best :: Ordering -> Profile -> Steps s a -> Steps s a -> Steps s a Dislike :: Steps s a -> Steps s a Log :: String -> Steps s a -> Steps s a Fail :: Steps s a -- profile !! s = number of Dislikes found to do s Shifts data ProfileF a = PSusp | PFail | PRes a | !a :> ProfileF a deriving (Show, Functor) type Profile = ProfileF Int -- Map lookahead to maximum dislike difference we accept. When looking much further, -- we are more prone to discard smaller differences. It's essential that this drops below 0 when -- its argument increases, so that we can discard things with dislikes using only -- finite lookahead. dislikeThreshold :: Int -> Int dislikeThreshold n | n < 5 = 0 | otherwise = -1 -- we looked 5 tokens ahead, and still have no clue who is the best. Pick at random. -- | Compute the combination of two profiles, as well as which one is the best. better :: Int -> Profile -> Profile -> (Ordering, Profile) better _ PFail p = (GT, p) -- avoid failure better _ p PFail = (LT, p) better _ PSusp _ = (EQ, PSusp) -- could not decide before suspension => leave undecided. better _ _ PSusp = (EQ, PSusp) better _ (PRes x) (PRes y) = if x <= y then (LT, PRes x) else (GT, PRes y) -- two results, just pick the best. better lk xs@(PRes x) (y:>ys) = if x == 0 || y-x > dislikeThreshold lk then (LT, xs) else min x y +> better (lk+1) xs ys better lk (y:>ys) xs@(PRes x) = if x == 0 || y-x > dislikeThreshold lk then (GT, xs) else min x y +> better (lk+1) ys xs better lk (x:>xs) (y:>ys) | x == 0 && y == 0 = recur -- never drop things with no error: this ensures to find a correct parse if it exists. | x - y > threshold = (GT, y:>ys) | y - x > threshold = (LT, x:>xs) -- if at any point something is too disliked, drop it. | otherwise = recur where threshold = dislikeThreshold lk recur = min x y +> better (lk + 1) xs ys (+>) :: Int -> (t, Profile) -> (t, Profile) x +> ~(ordering, xs) = (ordering, x :> xs) data LogEntry = LLog String | LEmpty | LDislike | LShift | LDone | LFail | LSusp | LS String deriving Show rightLog :: Steps s r -> Tree LogEntry rightLog (Val _ p) = rightLog p rightLog (App p) = rightLog p rightLog (Shift p) = Node LShift [rightLog p] rightLog (Done) = Node LDone [] rightLog (Fail) = Node LFail [] rightLog (Dislike p) = Node LDislike [rightLog p] rightLog (Log msg p) = Node (LLog msg) [rightLog p] rightLog (Sus _ _) = Node LSusp [] rightLog (Best _ _ l r) = Node LEmpty (rightLog l:[rightLog r]) rightLog (Sh' _) = error "Sh' should be hidden by Sus" profile :: Steps s r -> Profile profile (Val _ p) = profile p profile (App p) = profile p profile (Shift p) = 0 :> profile p profile (Done) = PRes 0 -- success with zero dislikes profile (Fail) = PFail profile (Dislike p) = fmap succ (profile p) profile (Log _ p) = profile p profile (Sus _ _) = PSusp profile (Best _ pr _ _) = pr profile (Sh' _) = error "Sh' should be hidden by Sus" instance Show (Steps s r) where show (Val _ p) = 'v' : show p show (App p) = '*' : show p show (Done) = "1" show (Shift p) = '>' : show p show (Sh' p) = '\'' : show p show (Dislike p) = '?' : show p show (Log msg p) = "[" ++ msg ++ "]" ++ show p show (Fail) = "0" show (Sus _ _) = "..." show (Best _ _ p q) = "(" ++ show p ++ ")" ++ show q countWidth :: Zip s r -> Int countWidth (Zip _ _ r) = countWidth' r where countWidth' :: Steps s r -> Int countWidth' r' = case r' of (Best _ _ p q) -> countWidth' p + countWidth' q (Val _ p) -> countWidth' p (App p) -> countWidth' p (Done) -> 1 (Shift p) -> countWidth' p (Sh' p) -> countWidth' p (Dislike p) -> countWidth' p (Log _ p) -> countWidth' p (Fail) -> 1 (Sus _ _) -> 1 instance Show (RPolish i o) where show (RPush _ p) = show p ++ "^" show (RApp p) = show p ++ "@" show (RStop) = "!" apply :: forall t t1 a. ((t -> a) :< (t :< t1)) -> a :< t1 apply ~(f:< ~(a: (r, [String]) evalR' Done = ((), []) evalR' (Val a r) = first (a :<) (evalR' r) evalR' (App s) = first apply (evalR' s) evalR' (Shift v) = evalR' v evalR' (Dislike v) = evalR' v evalR' (Log err v) = second (err:) (evalR' v) evalR' (Fail) = error "evalR: No parse!" evalR' (Sus _ _) = error "evalR: Not fully evaluated!" evalR' (Sh' _) = error "evalR: Sh' should be hidden by Sus" evalR' (Best choice _ p q) = case choice of LT -> evalR' p GT -> evalR' q EQ -> error $ "evalR: Ambiguous parse: " ++ show p ++ " ~~~ " ++ show q instance Functor (Parser s) where fmap f = (pure f <*>) instance Applicative (Parser s) where (<*>) = Appl pure = Pure instance Alternative (Parser s) where (<|>) = Disj empty = Empt instance Monad (Parser s) where (>>=) = Bind return = pure #if (!MIN_VERSION_base(4,13,0)) fail _message = Empt #endif instance Fail.MonadFail (Parser s) where fail _message = Empt toQ :: Parser s a -> forall h r. ((h,a) -> Steps s r) -> h -> Steps s r toQ (Look a f) = \k h -> Sus (toQ a k h) (\s -> toQ (f s) k h) toQ (p `Appl` q) = \k -> toQ p $ toQ q $ \((h, b2a), b) -> k (h, b2a b) toQ (Pure a) = \k h -> k (h, a) toQ (Disj p q) = \k h -> iBest (toQ p k h) (toQ q k h) toQ (Bind p a2q) = \k -> toQ p (\(h,a) -> toQ (a2q a) k h) toQ Empt = \_k _h -> Fail toQ (Yuck p) = \k h -> Dislike $ toQ p k h toQ (Enter err p) = \k h -> Log err $ toQ p k h toQ (Shif p) = \k h -> Sh' $ toQ p k h toP :: Parser s a -> forall r. Steps s r -> Steps s (a :< r) toP (Look a f) = {-# SCC "toP_Look" #-} \fut -> Sus (toP a fut) (\s -> toP (f s) fut) toP (Appl f x) = {-# SCC "toP_Appl" #-} App . toP f . toP x toP (Pure x) = {-# SCC "toP_Pure" #-} Val x toP Empt = {-# SCC "toP_Empt" #-} const Fail toP (Disj a b) = {-# SCC "toP_Disj" #-} \fut -> iBest (toP a fut) (toP b fut) toP (Bind p a2q) = {-# SCC "toP_Bind" #-} \fut -> toQ p (\(_,a) -> toP (a2q a) fut) () toP (Yuck p) = {-# SCC "toP_Yuck" #-} Dislike . toP p toP (Enter err p) = {-# SCC "toP_Enter" #-} Log err . toP p toP (Shif p) = {-# SCC "toP_Shif" #-} Sh' . toP p -- | Intelligent, caching best. iBest :: Steps s a -> Steps s a -> Steps s a iBest p q = let ~(choice, pr) = better 0 (profile p) (profile q) in Best choice pr p q symbol :: forall s. (s -> Bool) -> Parser s s symbol f = Look empty $ \s -> if f s then Shif $ pure s else empty eof :: forall s. Parser s () eof = Look (pure ()) (const empty) -- | Push a chunk of symbols or eof in the process. This forces some suspensions. feed :: Maybe [s] -> Steps s r -> Steps s r feed (Just []) p = p -- nothing more left to feed feed ss p = case p of (Sus nil cons) -> case ss of Just [] -> p -- no more info, stop feeding Nothing -> feed Nothing nil -- finish Just (s:_) -> feed ss (cons s) (Shift p') -> Shift (feed ss p') (Sh' p') -> Shift (feed (fmap (drop 1) ss) p') (Dislike p') -> Dislike (feed ss p') (Log err p') -> Log err (feed ss p') (Val x p') -> Val x (feed ss p') (App p') -> App (feed ss p') Done -> Done Fail -> Fail Best _ _ p' q' -> iBest (feed ss p') (feed ss q') -- TODO: it would be nice to be able to reuse the profile here. feedZ :: Maybe [s] -> Zip s r -> Zip s r feedZ x = onRight (feed x) -- Move the zipper to right, and simplify if something is pushed in -- the left part. evalL :: forall s output. Zip s output -> Zip s output evalL (Zip errs0 l0 r0) = help errs0 l0 r0 where help :: [String] -> RPolish mid output -> Steps s mid -> Zip s output help errs l rhs = case rhs of (Val a r) -> help errs (simplify (RPush a l)) r (App r) -> help errs (RApp l) r (Shift p) -> help errs l p (Log err p) -> help (err:errs) l p (Dislike p) -> help errs l p (Best choice _ p q) -> case choice of LT -> help errs l p GT -> help errs l q EQ -> reZip errs l rhs -- don't know where to go: don't speculate on evaluating either branch. _ -> reZip errs l rhs reZip :: [String] -> RPolish mid output -> Steps s mid -> Zip s output reZip errs l r = l `seq` Zip errs l r evalL' :: Zip s output -> Zip s output evalL' (Zip errs0 l0 r0) = Zip errs0 l0 (simplRhs r0) where simplRhs :: Steps s a ->Steps s a simplRhs rhs = case rhs of (Val a r) -> Val a (simplRhs r) (App r) -> App (simplRhs r) (Shift p) -> Shift (simplRhs p) (Log err p) -> Log err $ simplRhs p (Dislike p) -> Dislike $ simplRhs p (Best choice _ p q) -> case choice of LT -> simplRhs p GT -> simplRhs q EQ -> iBest (simplRhs p) (simplRhs q) x -> x -- | Push some symbols. pushSyms :: forall s r. [s] -> Zip s r -> Zip s r pushSyms x = feedZ (Just x) -- | Push eof pushEof :: forall s r. Zip s r -> Zip s r pushEof = feedZ Nothing -- | Make a parser into a process. mkProcess :: forall s a. Parser s a -> Process s a mkProcess p = Zip [] RStop (toP p Done) -- | Run a process (in case you do not need the incremental interface) run :: Process s a -> [s] -> (a, [String]) run p input = evalR $ pushEof $ pushSyms input p testNext :: (Maybe s -> Bool) -> Parser s () testNext f = Look (if f Nothing then ok else empty) (\s -> if f $ Just s then ok else empty) where ok = pure () lookNext :: Parser s (Maybe s) lookNext = Look (pure Nothing) (pure . Just) -- | Parse the same thing as the argument, but will be used only as -- backup. ie, it will be used only if disjuncted with a failing -- parser. recoverWith :: Parser s a -> Parser s a recoverWith = Enter "recoverWith" . Yuck ---------------------------------------------------- -------------------------------- -- The zipper for efficient evaluation: -- Arbitrary expressions in Reverse Polish notation. -- This can also be seen as an automaton that transforms a stack. -- RPolish is indexed by the types in the stack consumed by the automaton (input), -- and the stack produced (output) data RPolish input output where RPush :: a -> RPolish (a :< rest) output -> RPolish rest output RApp :: RPolish (b :< rest) output -> RPolish ((a -> b) :< a :< rest) output RStop :: RPolish rest rest -- Evaluate the output of an RP automaton, given an input stack evalRP :: RPolish input output -> input -> output evalRP RStop acc = acc evalRP (RPush v r) acc = evalRP r (v :< acc) evalRP (RApp r) ~(f :< ~(a :< rest)) = evalRP r (f a :< rest) -- execute the automaton as far as possible simplify :: RPolish s output -> RPolish s output simplify (RPush x (RPush f (RApp r))) = simplify (RPush (f x) r) simplify x = x evalR :: Zip token (a :< rest) -> (a, [String]) evalR (Zip errs l r) = ((top . evalRP l) *** (errs ++)) (evalR' r) -- Gluing a Polish expression and an RP automaton. -- This can also be seen as a zipper of Polish expressions. data Zip s output where Zip :: [String] -> RPolish mid output -> Steps s mid -> Zip s output -- note that the Stack produced by the Polish expression matches -- the stack consumed by the RP automaton. fullLog :: Zip s output -> ([String],Tree LogEntry) fullLog (Zip msg _ rhs) = (reverse msg, rightLog rhs) instance Show (Zip s output) where show (Zip errs l r) = show l ++ "<>" ++ show r ++ ", errs = " ++ show errs onRight :: (forall r. Steps s r -> Steps s r) -> Zip s a -> Zip s a onRight f (Zip errs x y) = Zip errs x (f y) type Process token result = Zip token (result :< ()) yi-core-0.19.4/src/System/0000755000000000000000000000000007346545000013420 5ustar0000000000000000yi-core-0.19.4/src/System/CanonicalizePath.hs0000644000000000000000000000625707346545000017202 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : System.CanonicalizePath -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- System.Directory.canonicalizePath replacement module System.CanonicalizePath ( canonicalizePath , replaceShorthands ) where #ifdef mingw32_HOST_OS import System.FilePath (normalise) import qualified System.Win32 as Win32 #endif import Control.Exc (ignoringException) import Control.Monad (foldM) import Data.List.Split (splitOneOf) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, empty, splitOn) import System.Directory (getCurrentDirectory) import System.FilePath (isAbsolute, isDrive, pathSeparator, pathSeparators, takeDirectory, ()) import System.PosixCompat.Files (readSymbolicLink) -- | Returns absolute name of the file, which doesn't contain -- any `/./`, `/../`, `//` sequences or symlinks canonicalizePath :: FilePath -> IO FilePath canonicalizePath path = do #if !defined(mingw32_HOST_OS) absPath <- makeAbsolute path foldM (\x y -> expandSym $ combinePath x y) "/" $ splitPath absPath #else Win32.getFullPathName . normalise $ path #endif -- | Dereferences symbolic links until regular -- file/directory/something_else appears expandSym :: FilePath -> IO FilePath expandSym fpath = do -- System.Posix.Files.getFileStatus dereferences symlink before -- checking its status, so it's useless here deref <- ignoringException (Just <$> readSymbolicLink fpath) case deref of Just slink -> expandSym (if isAbsolute slink then slink else foldl combinePath (takeDirectory fpath) $ splitPath slink) Nothing -> return fpath -- | Make a path absolute. makeAbsolute :: FilePath -> IO FilePath makeAbsolute f | not (null f) && head f `elem` ['~', pathSeparator] = return f | otherwise = fmap ( f) getCurrentDirectory -- | Combines two paths, moves up one level on .. combinePath :: FilePath -> String -> FilePath combinePath x "." = x combinePath x ".." = takeDirectory x combinePath "/" y = "/" y combinePath x y | isDrive x = (x ++ [pathSeparator]) y -- "C:" "bin" = "C:bin" | otherwise = x y -- Replace utility shorthands, similar to Emacs -- -- @ -- somepath//someotherpath ≅ /someotherpath -- somepath/~/someotherpath ≅ ~/someotherpath -- @ replaceShorthands :: T.Text -> T.Text replaceShorthands = r "/~" "~/" . r "//" "/" where r :: T.Text -> T.Text -> T.Text -> T.Text r s r' a = case T.splitOn s a of [] -> T.empty [a'] -> a' _ : as -> r' <> last as -- | Splits path into parts by path separator -- -- Text version would look like -- -- @'T.filter' (not . T.null) . T.split (`elem` pathSeparators)@ -- -- But we should move to @system-filepath@ package anyway. splitPath :: FilePath -> [String] splitPath = filter (not . null) . splitOneOf pathSeparators yi-core-0.19.4/src/System/FriendlyPath.hs0000644000000000000000000000265607346545000016356 0ustar0000000000000000{-# LANGUAGE CPP #-} module System.FriendlyPath ( userToCanonPath , expandTilda , isAbsolute' ) where import System.CanonicalizePath (canonicalizePath) import System.Directory (getHomeDirectory) import System.FilePath (isAbsolute, normalise, pathSeparator) #ifndef mingw32_HOST_OS import System.Posix.User (getUserEntryForName, homeDirectory) #endif -- canonicalizePath follows symlinks, and does not work if the directory does not exist. -- | Canonicalize a user-friendly path userToCanonPath :: FilePath -> IO String userToCanonPath f = canonicalizePath =<< expandTilda f -- | Turn a user-friendly path into a computer-friendly path by expanding the leading tilda. expandTilda :: String -> IO FilePath expandTilda ('~':path) | null path || (head path == pathSeparator) = (++ path) <$> getHomeDirectory #ifndef mingw32_HOST_OS -- Home directory of another user, e.g. ~root/ | otherwise = let username = takeWhile (/= pathSeparator) path dirname = drop (length username) path in (normalise . (++ dirname) . homeDirectory) <$> getUserEntryForName username #else -- unix-compat no longer helps | otherwise = ioError $ mkIOError illegalOperationErrorType "Tilda expansion only supported under Unix" Nothing Nothing #endif expandTilda path = return path -- | Is a user-friendly path absolute? isAbsolute' :: String -> Bool isAbsolute' ('~':_) = True isAbsolute' p = isAbsolute p yi-core-0.19.4/src/0000755000000000000000000000000007346545000012134 5ustar0000000000000000yi-core-0.19.4/src/Yi.hs0000644000000000000000000000213207346545000013047 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Facade of the Yi library, for use by configuration file. Just -- re-exports a bunch of modules. -- -- You should therefore: -- -- @ import Yi@ -- -- in your @~/.config/yi/yi.hs@. module Yi ( module Data.Prototype, -- prototypes are mainly there for config; makes sense to export them. module Yi.Buffer, module Yi.Config, module Yi.Config.Default, module Yi.Core, module Yi.Dired, module Yi.Editor, module Yi.Eval, module Yi.File, module Yi.Keymap, module Yi.Keymap.Keys, module Yi.Misc, module Yi.Search, module Yi.Style, module Yi.Style.Library, ) where import Data.Prototype import Yi.Buffer import Yi.Config import Yi.Config.Default import Yi.Core import Yi.Dired import Yi.Editor import Yi.Eval import Yi.File import Yi.Keymap import Yi.Keymap.Keys import Yi.Misc import Yi.Search import Yi.Style import Yi.Style.Libraryyi-core-0.19.4/src/Yi/0000755000000000000000000000000007346545000012515 5ustar0000000000000000yi-core-0.19.4/src/Yi/Buffer.hs0000644000000000000000000000176407346545000014272 0ustar0000000000000000{-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- The 'Buffer' module defines monadic editing operations over -- one-dimensional buffers, maintaining a current /point/. -- -- This module acts as a facade for the Buffer.* modules. module Yi.Buffer ( module Yi.Buffer.Basic , module Yi.Buffer.HighLevel , module Yi.Buffer.Indent , module Yi.Buffer.Misc , module Yi.Buffer.Normal , module Yi.Buffer.Region , module Yi.Buffer.TextUnit , module Yi.Buffer.Undo -- Implementation re-exports (move out of implementation?) , UIUpdate (..) , Update (..) , updateIsDelete , markGravityAA , markPointAA ) where import Yi.Buffer.Basic import Yi.Buffer.HighLevel import Yi.Buffer.Indent import Yi.Buffer.Misc import Yi.Buffer.Normal import Yi.Buffer.Region import Yi.Buffer.TextUnit import Yi.Buffer.Undo import Yi.Buffer.Implementation yi-core-0.19.4/src/Yi/Buffer/0000755000000000000000000000000007346545000013726 5ustar0000000000000000yi-core-0.19.4/src/Yi/Buffer/HighLevel.hs0000644000000000000000000011614407346545000016140 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MultiWayIf #-} -- | -- Module : Yi.Buffer.HighLevel -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- High level operations on buffers. module Yi.Buffer.HighLevel ( atEof , atEol , atLastLine , atSol , atSof , bdeleteB , bdeleteLineB , bkillWordB , botB , bufInfoB , BufferFileInfo (..) , capitaliseWordB , deleteBlankLinesB , deleteHorizontalSpaceB , deleteRegionWithStyleB , deleteToEol , deleteTrailingSpaceB , downFromTosB , downScreenB , downScreensB , exchangePointAndMarkB , fillParagraph , findMatchingPairB , firstNonSpaceB , flipRectangleB , getBookmarkB , getLineAndCol , getLineAndColOfPoint , getNextLineB , getNextNonBlankLineB , getRawestSelectRegionB , getSelectionMarkPointB , getSelectRegionB , gotoCharacterB , hasWhiteSpaceBefore , incrementNextNumberByB , insertRopeWithStyleB , isCurrentLineAllWhiteSpaceB , isCurrentLineEmptyB , isNumberB , killWordB , lastNonSpaceB , leftEdgesOfRegionB , leftOnEol , lineMoveVisRel , linePrefixSelectionB , lineStreamB , lowercaseWordB , middleB , modifyExtendedSelectionB , moveNonspaceOrSol , movePercentageFileB , moveToMTB , moveToEol , moveToSol , moveXorEol , moveXorSol , nextCExc , nextCInc , nextCInLineExc , nextCInLineInc , nextNParagraphs , nextWordB , prevCExc , prevCInc , prevCInLineExc , prevCInLineInc , prevNParagraphs , prevWordB , readCurrentWordB , readLnB , readPrevWordB , readRegionRopeWithStyleB , replaceBufferContent , revertB , rightEdgesOfRegionB , scrollB , scrollCursorToBottomB , scrollCursorToTopB , scrollScreensB , scrollToCursorB , scrollToLineAboveWindowB , scrollToLineBelowWindowB , selectNParagraphs , setSelectionMarkPointB , setSelectRegionB , shapeOfBlockRegionB , sortLines , sortLinesWithRegion , snapInsB , snapScreenB , splitBlockRegionToContiguousSubRegionsB , swapB , switchCaseChar , test3CharB , testHexB , toggleCommentB , topB , unLineCommentSelectionB , upFromBosB , uppercaseWordB , upScreenB , upScreensB , vimScrollB , vimScrollByB , markWord ) where import Lens.Micro.Platform (over, use, (%=), (.=), _last) import Control.Monad (forM, forM_, replicateM_, unless, void, when) import Control.Monad.RWS.Strict (ask) import Control.Monad.State (gets) import Data.Char (isDigit, isHexDigit, isOctDigit, isSpace, isUpper, toLower, toUpper) import Data.List (intersperse, sort) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T (Text, toLower, toUpper, unpack) import Data.Time (UTCTime) import Data.Tuple (swap) import Numeric (readHex, readOct, showHex, showOct) import Yi.Buffer.Basic (Direction (..), Mark, Point (..), Size (Size)) import Yi.Buffer.Misc import Yi.Buffer.Normal import Yi.Buffer.Region import Yi.Config.Misc (ScrollStyle (SingleLine)) import Yi.Rope (YiString) import qualified Yi.Rope as R import Yi.String (capitalizeFirst, fillText, isBlank, mapLines, onLines, overInit) import Yi.Utils (SemiNum ((+~), (-~))) import Yi.Window (Window (actualLines, width, wkey)) -- --------------------------------------------------------------------- -- Movement operations -- | Move point between the middle, top and bottom of the screen -- If the point stays at the middle, it'll be gone to the top -- else if the point stays at the top, it'll be gone to the bottom -- else it'll be gone to the middle moveToMTB :: BufferM () moveToMTB = (==) <$> curLn <*> screenMidLn >>= \case True -> downFromTosB 0 _ -> (==) <$> curLn <*> screenTopLn >>= \case True -> upFromBosB 0 _ -> downFromTosB =<< (-) <$> screenMidLn <*> screenTopLn -- | Move point to start of line moveToSol :: BufferM () moveToSol = maybeMoveB Line Backward -- | Move point to end of line moveToEol :: BufferM () moveToEol = maybeMoveB Line Forward -- | Move cursor to origin topB :: BufferM () topB = moveTo 0 -- | Move cursor to end of buffer botB :: BufferM () botB = moveTo =<< sizeB -- | Move left if on eol, but not on blank line leftOnEol :: BufferM () -- @savingPrefCol@ is needed, because deep down @leftB@ contains @forgetPrefCol@ -- which messes up vertical cursor motion in Vim normal mode leftOnEol = savingPrefCol $ do eol <- atEol sol <- atSol when (eol && not sol) leftB -- | Move @x@ chars back, or to the sol, whichever is less moveXorSol :: Int -> BufferM () moveXorSol x = replicateM_ x $ do c <- atSol; unless c leftB -- | Move @x@ chars forward, or to the eol, whichever is less moveXorEol :: Int -> BufferM () moveXorEol x = replicateM_ x $ do c <- atEol; unless c rightB -- | Move to first char of next word forwards nextWordB :: BufferM () nextWordB = moveB unitWord Forward -- | Move to first char of next word backwards prevWordB :: BufferM () prevWordB = moveB unitWord Backward -- * Char-based movement actions. gotoCharacterB :: Char -> Direction -> RegionStyle -> Bool -> BufferM () gotoCharacterB c dir style stopAtLineBreaks = do start <- pointB let predicate = if stopAtLineBreaks then (`elem` [c, '\n']) else (== c) (move, moveBack) = if dir == Forward then (rightB, leftB) else (leftB, rightB) doUntilB_ (predicate <$> readB) move b <- readB if stopAtLineBreaks && b == '\n' then moveTo start else when (style == Exclusive && b == c) moveBack -- | Move to the next occurrence of @c@ nextCInc :: Char -> BufferM () nextCInc c = gotoCharacterB c Forward Inclusive False nextCInLineInc :: Char -> BufferM () nextCInLineInc c = gotoCharacterB c Forward Inclusive True -- | Move to the character before the next occurrence of @c@ nextCExc :: Char -> BufferM () nextCExc c = gotoCharacterB c Forward Exclusive False nextCInLineExc :: Char -> BufferM () nextCInLineExc c = gotoCharacterB c Forward Exclusive True -- | Move to the previous occurrence of @c@ prevCInc :: Char -> BufferM () prevCInc c = gotoCharacterB c Backward Inclusive False prevCInLineInc :: Char -> BufferM () prevCInLineInc c = gotoCharacterB c Backward Inclusive True -- | Move to the character after the previous occurrence of @c@ prevCExc :: Char -> BufferM () prevCExc c = gotoCharacterB c Backward Exclusive False prevCInLineExc :: Char -> BufferM () prevCInLineExc c = gotoCharacterB c Backward Exclusive True -- | Move to first non-space character in this line firstNonSpaceB :: BufferM () firstNonSpaceB = do moveToSol untilB_ ((||) <$> atEol <*> ((not . isSpace) <$> readB)) rightB -- | Move to the last non-space character in this line lastNonSpaceB :: BufferM () lastNonSpaceB = do moveToEol untilB_ ((||) <$> atSol <*> ((not . isSpace) <$> readB)) leftB -- | Go to the first non space character in the line; -- if already there, then go to the beginning of the line. moveNonspaceOrSol :: BufferM () moveNonspaceOrSol = do prev <- readPreviousOfLnB if R.all isSpace prev then moveToSol else firstNonSpaceB -- | True if current line consists of just a newline (no whitespace) isCurrentLineEmptyB :: BufferM Bool isCurrentLineEmptyB = savingPointB $ moveToSol >> atEol -- | Note: Returns False if line doesn't have any characters besides a newline isCurrentLineAllWhiteSpaceB :: BufferM Bool isCurrentLineAllWhiteSpaceB = savingPointB $ do isEmpty <- isCurrentLineEmptyB if isEmpty then return False else do let go = do eol <- atEol if eol then return True else do c <- readB if isSpace c then rightB >> go else return False moveToSol go ------------ -- | Move down next @n@ paragraphs nextNParagraphs :: Int -> BufferM () nextNParagraphs n = replicateM_ n $ moveB unitEmacsParagraph Forward -- | Move up prev @n@ paragraphs prevNParagraphs :: Int -> BufferM () prevNParagraphs n = replicateM_ n $ moveB unitEmacsParagraph Backward -- | Select next @n@ paragraphs selectNParagraphs :: Int -> BufferM () selectNParagraphs n = do getVisibleSelection >>= \case True -> exchangePointAndMarkB >> nextNParagraphs n >> (setVisibleSelection True) >> exchangePointAndMarkB False -> nextNParagraphs n >> (setVisibleSelection True) >> pointB >>= setSelectionMarkPointB >> prevNParagraphs n -- ! Examples: -- @goUnmatchedB Backward '(' ')'@ -- Move to the previous unmatched '(' -- @goUnmatchedB Forward '{' '}'@ -- Move to the next unmatched '}' goUnmatchedB :: Direction -> Char -> Char -> BufferM () goUnmatchedB dir cStart' cStop' = getLineAndCol >>= \position -> stepB >> readB >>= go position (0::Int) where go pos opened c | c == cStop && opened == 0 = return () | c == cStop = goIfNotEofSof pos (opened-1) | c == cStart = goIfNotEofSof pos (opened+1) | otherwise = goIfNotEofSof pos opened goIfNotEofSof pos opened = atEof >>= \eof -> atSof >>= \sof -> if not eof && not sof then stepB >> readB >>= go pos opened else gotoLn (fst pos) >> moveToColB (snd pos) (stepB, cStart, cStop) | dir == Forward = (rightB, cStart', cStop') | otherwise = (leftB, cStop', cStart') ----------------------------------------------------------------------- -- Queries -- | Return true if the current point is the start of a line atSol :: BufferM Bool atSol = atBoundaryB Line Backward -- | Return true if the current point is the end of a line atEol :: BufferM Bool atEol = atBoundaryB Line Forward -- | True if point at start of file atSof :: BufferM Bool atSof = atBoundaryB Document Backward -- | True if point at end of file atEof :: BufferM Bool atEof = atBoundaryB Document Forward -- | True if point at the last line atLastLine :: BufferM Bool atLastLine = savingPointB $ do moveToEol (==) <$> sizeB <*> pointB -- | Get the current line and column number getLineAndCol :: BufferM (Int, Int) getLineAndCol = (,) <$> curLn <*> curCol getLineAndColOfPoint :: Point -> BufferM (Int, Int) getLineAndColOfPoint p = savingPointB $ moveTo p >> getLineAndCol -- | Read the line the point is on readLnB :: BufferM YiString readLnB = readUnitB Line -- | Read from point to beginning of line readPreviousOfLnB :: BufferM YiString readPreviousOfLnB = readRegionB =<< regionOfPartB Line Backward hasWhiteSpaceBefore :: BufferM Bool hasWhiteSpaceBefore = fmap isSpace (prevPointB >>= readAtB) -- | Get the previous point, unless at the beginning of the file prevPointB :: BufferM Point prevPointB = do sof <- atSof if sof then pointB else do p <- pointB return $ Point (fromPoint p - 1) -- | Reads in word at point. readCurrentWordB :: BufferM YiString readCurrentWordB = readUnitB unitWord -- | Reads in word before point. readPrevWordB :: BufferM YiString readPrevWordB = readPrevUnitB unitViWordOnLine ------------------------- -- Deletes -- | Delete one character backward bdeleteB :: BufferM () bdeleteB = deleteB Character Backward -- | Delete forward whitespace or non-whitespace depending on -- the character under point. killWordB :: BufferM () killWordB = deleteB unitWord Forward -- | Delete backward whitespace or non-whitespace depending on -- the character before point. bkillWordB :: BufferM () bkillWordB = deleteB unitWord Backward -- | Delete backward to the sof or the new line character bdeleteLineB :: BufferM () bdeleteLineB = atSol >>= \sol -> if sol then bdeleteB else deleteB Line Backward -- UnivArgument is in Yi.Keymap.Emacs.Utils but we can't import it due -- to cyclic imports. -- | emacs' @delete-horizontal-space@ with the optional argument. deleteHorizontalSpaceB :: Maybe Int -> BufferM () deleteHorizontalSpaceB u = do c <- curCol reg <- regionOfB Line text <- readRegionB reg let (r, jb) = deleteSpaces c text modifyRegionB (const r) reg -- Jump backwards to where the now-deleted spaces have started so -- it's consistent and feels natural instead of leaving us somewhere -- in the text. moveToColB $ c - jb where deleteSpaces :: Int -> R.YiString -> (R.YiString, Int) deleteSpaces c l = let (f, b) = R.splitAt c l f' = R.dropWhileEnd isSpace f cleaned = f' <> case u of Nothing -> R.dropWhile isSpace b Just _ -> b -- We only want to jump back the number of spaces before the -- point, not the total number of characters we're removing. in (cleaned, R.length f - R.length f') ---------------------------------------- -- Transform operations -- | capitalise the word under the cursor uppercaseWordB :: BufferM () uppercaseWordB = transformB (R.withText T.toUpper) unitWord Forward -- | lowerise word under the cursor lowercaseWordB :: BufferM () lowercaseWordB = transformB (R.withText T.toLower) unitWord Forward -- | capitalise the first letter of this word capitaliseWordB :: BufferM () capitaliseWordB = transformB capitalizeFirst unitWord Forward switchCaseChar :: Char -> Char switchCaseChar c = if isUpper c then toLower c else toUpper c -- | Delete to the end of line, excluding it. deleteToEol :: BufferM () deleteToEol = deleteRegionB =<< regionOfPartB Line Forward -- | Transpose two characters, (the Emacs C-t action) swapB :: BufferM () swapB = do eol <- atEol when eol leftB transposeB Character Forward -- | Delete trailing whitespace from all lines. Uses 'savingPositionB' -- to get back to where it was. deleteTrailingSpaceB :: BufferM () deleteTrailingSpaceB = regionOfB Document >>= savingPositionB . modifyRegionB (tru . mapLines stripEnd) where -- Strips the space from the end of each line, preserving -- newlines. stripEnd :: R.YiString -> R.YiString stripEnd x = case R.last x of Nothing -> x Just '\n' -> (`R.snoc` '\n') $ R.dropWhileEnd isSpace x _ -> R.dropWhileEnd isSpace x -- | Cut off trailing newlines, making sure to preserve one. tru :: R.YiString -> R.YiString tru x = if R.length x == 0 then x else (`R.snoc` '\n') $ R.dropWhileEnd (== '\n') x -- ---------------------------------------------------- -- | Marks -- | Set the current buffer selection mark setSelectionMarkPointB :: Point -> BufferM () setSelectionMarkPointB p = (.= p) . markPointA =<< selMark <$> askMarks -- | Get the current buffer selection mark getSelectionMarkPointB :: BufferM Point getSelectionMarkPointB = use . markPointA =<< selMark <$> askMarks -- | Exchange point & mark. exchangePointAndMarkB :: BufferM () exchangePointAndMarkB = do m <- getSelectionMarkPointB p <- pointB setSelectionMarkPointB p moveTo m getBookmarkB :: String -> BufferM Mark getBookmarkB = getMarkB . Just -- --------------------------------------------------------------------- -- Buffer operations data BufferFileInfo = BufferFileInfo { bufInfoFileName :: FilePath , bufInfoSize :: Int , bufInfoLineNo :: Int , bufInfoColNo :: Int , bufInfoCharNo :: Point , bufInfoPercent :: T.Text , bufInfoModified :: Bool } -- | File info, size in chars, line no, col num, char num, percent bufInfoB :: BufferM BufferFileInfo bufInfoB = do s <- sizeB p <- pointB m <- gets isUnchangedBuffer l <- curLn c <- curCol nm <- gets identString let bufInfo = BufferFileInfo { bufInfoFileName = T.unpack nm , bufInfoSize = fromIntegral s , bufInfoLineNo = l , bufInfoColNo = c , bufInfoCharNo = p , bufInfoPercent = getPercent p s , bufInfoModified = not m } return bufInfo ----------------------------- -- Window-related operations upScreensB :: Int -> BufferM () upScreensB = scrollScreensB . negate downScreensB :: Int -> BufferM () downScreensB = scrollScreensB -- | Scroll up 1 screen upScreenB :: BufferM () upScreenB = scrollScreensB (-1) -- | Scroll down 1 screen downScreenB :: BufferM () downScreenB = scrollScreensB 1 -- | Scroll by n screens (negative for up) scrollScreensB :: Int -> BufferM () scrollScreensB n = do h <- askWindow actualLines scrollB $ n * max 0 (h - 1) -- subtract some amount to get some overlap (emacs-like). -- | Same as scrollB, but also moves the cursor vimScrollB :: Int -> BufferM () vimScrollB n = do scrollB n void $ lineMoveRel n -- | Same as scrollByB, but also moves the cursor vimScrollByB :: (Int -> Int) -> Int -> BufferM () vimScrollByB f n = do h <- askWindow actualLines vimScrollB $ n * f h -- | Move to middle line in screen scrollToCursorB :: BufferM () scrollToCursorB = do MarkSet f i _ <- markLines h <- askWindow actualLines let m = f + (h `div` 2) scrollB $ i - m -- | Move cursor to the top of the screen scrollCursorToTopB :: BufferM () scrollCursorToTopB = do MarkSet f i _ <- markLines scrollB $ i - f -- | Move cursor to the bottom of the screen scrollCursorToBottomB :: BufferM () scrollCursorToBottomB = do -- NOTE: This is only an approximation. -- The correct scroll amount depends on how many lines just above -- the current viewport are going to be wrapped. We don't have this -- information here as wrapping is done in the frontend. MarkSet f i _ <- markLines h <- askWindow actualLines scrollB $ i - f - h + 1 -- | Scroll by n lines. scrollB :: Int -> BufferM () scrollB n = do MarkSet fr _ _ <- askMarks savingPointB $ do moveTo =<< use (markPointA fr) void $ gotoLnFrom n (markPointA fr .=) =<< pointB w <- askWindow wkey pointFollowsWindowA %= Set.insert w -- Scroll line above window to the bottom. scrollToLineAboveWindowB :: BufferM () scrollToLineAboveWindowB = do downFromTosB 0 replicateM_ 1 lineUp scrollCursorToBottomB -- Scroll line below window to the top. scrollToLineBelowWindowB :: BufferM () scrollToLineBelowWindowB = do upFromBosB 0 replicateM_ 1 lineDown scrollCursorToTopB -- | Move the point to inside the viewable region snapInsB :: BufferM () snapInsB = do w <- askWindow wkey movePoint <- Set.member w <$> use pointFollowsWindowA when movePoint $ do r <- winRegionB p <- pointB moveTo $ max (regionStart r) $ min (regionEnd r) p -- | return index of Sol on line @n@ above current line indexOfSolAbove :: Int -> BufferM Point indexOfSolAbove n = pointAt $ gotoLnFrom (negate n) data RelPosition = Above | Below | Within deriving (Show) -- | return relative position of the point @p@ -- relative to the region defined by the points @rs@ and @re@ pointScreenRelPosition :: Point -> Point -> Point -> RelPosition pointScreenRelPosition p rs re | rs > p && p > re = Within | p < rs = Above | p > re = Below pointScreenRelPosition _ _ _ = Within -- just to disable the non-exhaustive pattern match warning -- | Move the visible region to include the point snapScreenB :: Maybe ScrollStyle -> BufferM Bool snapScreenB style = do w <- askWindow wkey movePoint <- Set.member w <$> use pointFollowsWindowA if movePoint then return False else do inWin <- pointInWindowB =<< pointB if inWin then return False else do h <- askWindow actualLines r <- winRegionB p <- pointB let gap = case style of Just SingleLine -> case pointScreenRelPosition p (regionStart r) (regionEnd r) of Above -> 0 Below -> h - 1 Within -> 0 -- Impossible but handle it anyway _ -> h `div` 2 i <- indexOfSolAbove gap f <- fromMark <$> askMarks markPointA f .= i return True -- | Move to @n@ lines down from top of screen downFromTosB :: Int -> BufferM () downFromTosB n = do moveTo =<< use . markPointA =<< fromMark <$> askMarks replicateM_ n lineDown -- | Move to @n@ lines up from the bottom of the screen upFromBosB :: Int -> BufferM () upFromBosB n = do r <- winRegionB moveTo (regionEnd r - 1) moveToSol replicateM_ n lineUp -- | Move to middle line in screen middleB :: BufferM () middleB = do w <- ask f <- fromMark <$> askMarks moveTo =<< use (markPointA f) replicateM_ (actualLines w `div` 2) lineDown pointInWindowB :: Point -> BufferM Bool pointInWindowB p = nearRegion p <$> winRegionB ----------------------------- -- Region-related operations -- | Return the region between point and mark getRawestSelectRegionB :: BufferM Region getRawestSelectRegionB = do m <- getSelectionMarkPointB p <- pointB return $ mkRegion p m -- | Return the empty region if the selection is not visible. getRawSelectRegionB :: BufferM Region getRawSelectRegionB = do s <- use highlightSelectionA if s then getRawestSelectRegionB else do p <- pointB return $ mkRegion p p -- | Get the current region boundaries. Extended to the current selection unit. getSelectRegionB :: BufferM Region getSelectRegionB = do regionStyle <- getRegionStyle r <- getRawSelectRegionB convertRegionToStyleB r regionStyle -- | Select the given region: set the selection mark at the 'regionStart' -- and the current point at the 'regionEnd'. setSelectRegionB :: Region -> BufferM () setSelectRegionB region = do highlightSelectionA .= True setSelectionMarkPointB $ regionStart region moveTo $ regionEnd region ------------------------------------------ -- Some line related movements/operations deleteBlankLinesB :: BufferM () deleteBlankLinesB = do isThisBlank <- isBlank <$> readLnB when isThisBlank $ do p <- pointB -- go up to the 1st blank line in the group void $ whileB (R.null <$> getNextLineB Backward) lineUp q <- pointB -- delete the whole blank region. deleteRegionB $ mkRegion p q -- | Get a (lazy) stream of lines in the buffer, starting at the /next/ line -- in the given direction. lineStreamB :: Direction -> BufferM [YiString] lineStreamB dir = fmap rev . R.lines <$> (streamB dir =<< pointB) where rev = case dir of Forward -> id Backward -> R.reverse -- | Get the next line of text in the given direction. This returns -- simply 'Nothing' if there no such line. getMaybeNextLineB :: Direction -> BufferM (Maybe YiString) getMaybeNextLineB dir = listToMaybe <$> lineStreamB dir -- | The same as 'getMaybeNextLineB' but avoids the use of the 'Maybe' -- type in the return by returning the empty string if there is no -- next line. getNextLineB :: Direction -> BufferM YiString getNextLineB dir = fromMaybe R.empty <$> getMaybeNextLineB dir -- | Get closest line to the current line (not including the current -- line) in the given direction which satisfies the given condition. -- Returns 'Nothing' if there is no line which satisfies the -- condition. getNextLineWhichB :: Direction -> (YiString -> Bool) -> BufferM (Maybe YiString) getNextLineWhichB dir cond = listToMaybe . filter cond <$> lineStreamB dir -- | Returns the closest line to the current line which is non-blank, -- in the given direction. Returns the empty string if there is no -- such line (for example if we are on the top line already). getNextNonBlankLineB :: Direction -> BufferM YiString getNextNonBlankLineB dir = fromMaybe R.empty <$> getNextLineWhichB dir (not . R.null) ------------------------------------------------ -- Some more utility functions involving -- regions (generally that which is selected) modifyExtendedSelectionB :: TextUnit -> (R.YiString -> R.YiString) -> BufferM () modifyExtendedSelectionB unit transform = modifyRegionB transform =<< unitWiseRegion unit =<< getSelectRegionB -- | Prefix each line in the selection using the given string. linePrefixSelectionB :: R.YiString -- ^ The string that starts a line comment -> BufferM () linePrefixSelectionB s = modifyExtendedSelectionB Line . overInit $ mapLines (s <>) -- | Uncomments the selection using the given line comment -- starting string. This only works for the comments which -- begin at the start of the line. unLineCommentSelectionB :: R.YiString -- ^ The string which begins a -- line comment -> R.YiString -- ^ A potentially shorter -- string that begins a comment -> BufferM () unLineCommentSelectionB s1 s2 = modifyExtendedSelectionB Line $ mapLines unCommentLine where (l1, l2) = (R.length s1, R.length s2) unCommentLine :: R.YiString -> R.YiString unCommentLine line = case (R.splitAt l1 line, R.splitAt l2 line) of ((f, s) , (f', s')) | s1 == f -> s | s2 == f' -> s' | otherwise -> line -- | Just like 'toggleCommentSelectionB' but automatically inserts a -- whitespace suffix to the inserted comment string. In fact: toggleCommentB :: R.YiString -> BufferM () toggleCommentB c = toggleCommentSelectionB (c `R.snoc` ' ') c -- | Toggle line comments in the selection by adding or removing a -- prefix to each line. toggleCommentSelectionB :: R.YiString -> R.YiString -> BufferM () toggleCommentSelectionB insPrefix delPrefix = do l <- readUnitB Line if delPrefix == R.take (R.length delPrefix) l then unLineCommentSelectionB insPrefix delPrefix else linePrefixSelectionB insPrefix -- | Replace the contents of the buffer with some string replaceBufferContent :: YiString -> BufferM () replaceBufferContent newvalue = do r <- regionOfB Document replaceRegionB r newvalue -- | Fill the text in the region so it fits nicely 80 columns. fillRegion :: Region -> BufferM () fillRegion = modifyRegionB (R.unlines . fillText 80) fillParagraph :: BufferM () fillParagraph = fillRegion =<< regionOfB unitParagraph -- | Sort the lines of the region. sortLines :: BufferM () sortLines = modifyExtendedSelectionB Line (onLines sort) -- | Forces an extra newline into the region (if one exists) modifyExtendedLRegion :: Region -> (R.YiString -> R.YiString) -> BufferM () modifyExtendedLRegion region transform = do reg <- unitWiseRegion Line region modifyRegionB transform (fixR reg) where fixR reg = mkRegion (regionStart reg) $ regionEnd reg + 1 sortLinesWithRegion :: Region -> BufferM () sortLinesWithRegion region = modifyExtendedLRegion region (onLines sort') where sort' [] = [] sort' lns = if hasnl (last lns) then sort lns else over _last -- should be completely safe since every element contains newline (fromMaybe (error "sortLinesWithRegion fromMaybe") . R.init) . sort $ over _last (`R.snoc` '\n') lns hasnl t | R.last t == Just '\n' = True | otherwise = False -- | Helper function: revert the buffer contents to its on-disk version revertB :: YiString -> UTCTime -> BufferM () revertB s now = do r <- regionOfB Document replaceRegionB r s markSavedB now -- get lengths of parts covered by block region -- -- Consider block region starting at 'o' and ending at 'z': -- -- start -- | -- \|/ -- def foo(bar): -- baz -- -- ab -- xyz0 -- /|\ -- | -- finish -- -- shapeOfBlockRegionB returns (regionStart, [2, 2, 0, 1, 2]) -- TODO: accept stickToEol flag shapeOfBlockRegionB :: Region -> BufferM (Point, [Int]) shapeOfBlockRegionB reg = savingPointB $ do (l0, c0) <- getLineAndColOfPoint $ regionStart reg (l1, c1) <- getLineAndColOfPoint $ regionEnd reg let (left, top, bottom, right) = (min c0 c1, min l0 l1, max l0 l1, max c0 c1) lengths <- forM [top .. bottom] $ \l -> do void $ gotoLn l moveToColB left currentLeft <- curCol if currentLeft /= left then return 0 else do moveToColB right rightAtEol <- atEol leftOnEol currentRight <- curCol return $ if currentRight == 0 && rightAtEol then 0 else currentRight - currentLeft + 1 startingPoint <- pointOfLineColB top left return (startingPoint, lengths) leftEdgesOfRegionB :: RegionStyle -> Region -> BufferM [Point] leftEdgesOfRegionB Block reg = savingPointB $ do (l0, _) <- getLineAndColOfPoint $ regionStart reg (l1, _) <- getLineAndColOfPoint $ regionEnd reg moveTo $ regionStart reg fmap catMaybes $ forM [0 .. abs (l0 - l1)] $ \i -> savingPointB $ do void $ lineMoveRel i p <- pointB eol <- atEol return (if not eol then Just p else Nothing) leftEdgesOfRegionB LineWise reg = savingPointB $ do lastSol <- do moveTo $ regionEnd reg moveToSol pointB let go acc p = do moveTo p moveToSol edge <- pointB if edge >= lastSol then return $ reverse (edge:acc) else do void $ lineMoveRel 1 go (edge:acc) =<< pointB go [] (regionStart reg) leftEdgesOfRegionB _ r = return [regionStart r] rightEdgesOfRegionB :: RegionStyle -> Region -> BufferM [Point] rightEdgesOfRegionB Block reg = savingPointB $ do (l0, _) <- getLineAndColOfPoint $ regionStart reg (l1, _) <- getLineAndColOfPoint $ regionEnd reg moveTo $ 1 + regionEnd reg fmap reverse $ forM [0 .. abs (l0 - l1)] $ \i -> savingPointB $ do void $ lineMoveRel $ -i pointB rightEdgesOfRegionB LineWise reg = savingPointB $ do lastEol <- do moveTo $ regionEnd reg moveToEol pointB let go acc p = do moveTo p moveToEol edge <- pointB if edge >= lastEol then return $ reverse (edge:acc) else do void $ lineMoveRel 1 go (edge:acc) =<< pointB go [] (regionStart reg) rightEdgesOfRegionB _ reg = savingPointB $ do moveTo $ regionEnd reg leftOnEol fmap return pointB splitBlockRegionToContiguousSubRegionsB :: Region -> BufferM [Region] splitBlockRegionToContiguousSubRegionsB reg = savingPointB $ do (start, lengths) <- shapeOfBlockRegionB reg forM (zip [0..] lengths) $ \(i, l) -> do moveTo start void $ lineMoveRel i p0 <- pointB moveXorEol l p1 <- pointB let subRegion = mkRegion p0 p1 return subRegion -- Return list containing a single point for all non-block styles. -- For Block return all the points along the left edge of the region deleteRegionWithStyleB :: Region -> RegionStyle -> BufferM (NonEmpty Point) deleteRegionWithStyleB reg Block = savingPointB $ do (start, lengths) <- shapeOfBlockRegionB reg moveTo start points <- forM (zip [1..] lengths) $ \(i, l) -> do deleteN l p <- pointB moveTo start lineMoveRel i return (if l == 0 then Nothing else Just p) return $ start :| drop 1 (catMaybes points) deleteRegionWithStyleB reg style = savingPointB $ do effectiveRegion <- convertRegionToStyleB reg style deleteRegionB effectiveRegion return $! pure (regionStart effectiveRegion) readRegionRopeWithStyleB :: Region -> RegionStyle -> BufferM YiString readRegionRopeWithStyleB reg Block = savingPointB $ do (start, lengths) <- shapeOfBlockRegionB reg moveTo start chunks <- forM lengths $ \l -> if l == 0 then lineMoveRel 1 >> return mempty else do p <- pointB r <- readRegionB $ mkRegion p (p +~ Size l) void $ lineMoveRel 1 return r return $ R.intersperse '\n' chunks readRegionRopeWithStyleB reg style = readRegionB =<< convertRegionToStyleB reg style insertRopeWithStyleB :: YiString -> RegionStyle -> BufferM () insertRopeWithStyleB rope Block = savingPointB $ do let ls = R.lines rope advanceLine = atLastLine >>= \case False -> void $ lineMoveRel 1 True -> do col <- curCol moveToEol newlineB insertN $ R.replicateChar col ' ' sequence_ $ intersperse advanceLine $ fmap (savingPointB . insertN) ls insertRopeWithStyleB rope LineWise = do moveToSol savingPointB $ insertN rope insertRopeWithStyleB rope _ = insertN rope -- consider the following buffer content -- -- 123456789 -- qwertyuio -- asdfgh -- -- The following examples use characters from that buffer as points. -- h' denotes the newline after h -- -- 1 r -> 4 q -- 9 q -> 1 o -- q h -> y a -- a o -> h' q -- o a -> q h' -- 1 a -> 1 a -- -- property: fmap swap (flipRectangleB a b) = flipRectangleB b a flipRectangleB :: Point -> Point -> BufferM (Point, Point) flipRectangleB p0 p1 = savingPointB $ do (_, c0) <- getLineAndColOfPoint p0 (_, c1) <- getLineAndColOfPoint p1 case compare c0 c1 of EQ -> return (p0, p1) GT -> swap <$> flipRectangleB p1 p0 LT -> do -- now we know that c0 < c1 moveTo p0 moveXorEol $ c1 - c0 flippedP0 <- pointB return (flippedP0, p1 -~ Size (c1 - c0)) movePercentageFileB :: Int -> BufferM () movePercentageFileB i = do let f :: Double f = case fromIntegral i / 100.0 of x | x > 1.0 -> 1.0 | x < 0.0 -> 0.0 -- Impossible? | otherwise -> x lineCount <- lineCountB void $ gotoLn $ floor (fromIntegral lineCount * f) firstNonSpaceB findMatchingPairB :: BufferM () findMatchingPairB = do let go dir a b = goUnmatchedB dir a b >> return True goToMatch = do c <- readB case c of '(' -> go Forward '(' ')' ')' -> go Backward '(' ')' '{' -> go Forward '{' '}' '}' -> go Backward '{' '}' '[' -> go Forward '[' ']' ']' -> go Backward '[' ']' _ -> otherChar otherChar = do eof <- atEof eol <- atEol if eof || eol then return False else rightB >> goToMatch p <- pointB foundMatch <- goToMatch unless foundMatch $ moveTo p -- Vim numbers -- | Increase (or decrease if negative) next number on line by n. incrementNextNumberByB :: Int -> BufferM () incrementNextNumberByB n = do start <- pointB untilB_ (not <$> isNumberB) $ moveXorSol 1 untilB_ isNumberB $ moveXorEol 1 begin <- pointB beginIsEol <- atEol untilB_ (not <$> isNumberB) $ moveXorEol 1 end <- pointB if beginIsEol then moveTo start else do modifyRegionB (increment n) (mkRegion begin end) moveXorSol 1 -- | Increment number in string by n. increment :: Int -> R.YiString -> R.YiString increment n l = R.fromString $ go (R.toString l) where go ('0':'x':xs) = (\ys -> '0':'x':ys) . (`showHex` "") . (+ n) . fst . head . readHex $ xs go ('0':'o':xs) = (\ys -> '0':'o':ys) . (`showOct` "") . (+ n) . fst . head . readOct $ xs go s = show . (+ n) . (\x -> read x :: Int) $ s -- | Is character under cursor a number. isNumberB :: BufferM Bool isNumberB = do eol <- atEol sol <- atSol if sol then isDigit <$> readB else if eol then return False else test3CharB -- | Used by isNumber to test if current character under cursor is a number. test3CharB :: BufferM Bool test3CharB = do moveXorSol 1 previous <- readB moveXorEol 2 next <- readB moveXorSol 1 current <- readB if | previous == '0' && current == 'o' && isOctDigit next -> return True -- octal format | previous == '0' && current == 'x' && isHexDigit next -> return True -- hex format | current == '-' && isDigit next -> return True -- negative numbers | isDigit current -> return True -- all decimal digits | isHexDigit current -> testHexB -- ['a'..'f'] for hex | otherwise -> return False -- | Characters ['a'..'f'] are part of a hex number only if preceded by 0x. -- Test if the current occurrence of ['a'..'f'] is part of a hex number. testHexB :: BufferM Bool testHexB = savingPointB $ do untilB_ (not . isHexDigit <$> readB) (moveXorSol 1) leftChar <- readB moveXorSol 1 leftToLeftChar <- readB if leftChar == 'x' && leftToLeftChar == '0' then return True else return False -- | Move point down by @n@ lines -- If line extends past width of window, count moving -- a single line as moving width points to the right. lineMoveVisRel :: Int -> BufferM () lineMoveVisRel = movingToPrefVisCol . lineMoveVisRelUp lineMoveVisRelUp :: Int -> BufferM () lineMoveVisRelUp 0 = return () lineMoveVisRelUp n | n < 0 = lineMoveVisRelDown $ negate n | otherwise = do wid <- width <$> use lastActiveWindowA col <- curCol len <- pointB >>= eolPointB >>= colOf let jumps = (len `div` wid) - (col `div` wid) next = n - jumps if next <= 0 then moveXorEol (n * wid) else do moveXorEol (jumps * wid) void $ gotoLnFrom 1 lineMoveVisRelUp $ next - 1 lineMoveVisRelDown :: Int -> BufferM () lineMoveVisRelDown 0 = return () lineMoveVisRelDown n | n < 0 = lineMoveVisRelUp $ negate n | otherwise = do wid <- width <$> use lastActiveWindowA col <- curCol let jumps = col `div` wid next = n - jumps if next <= 0 then leftN (n * wid) else do leftN (jumps * wid) void $ gotoLnFrom $ -1 moveToEol lineMoveVisRelDown $ next - 1 -- | Implements the same logic that emacs' `mark-word` does. -- Checks the mark point and moves it forth (or backward) for one word. markWord :: BufferM () markWord = do curPos <- pointB curMark <- getSelectionMarkPointB isVisible <- getVisibleSelection savingPointB $ do if not isVisible then nextWordB else do moveTo curMark if curMark < curPos then prevWordB else nextWordB setVisibleSelection True pointB >>= setSelectionMarkPointB yi-core-0.19.4/src/Yi/Buffer/Implementation.hs0000644000000000000000000004360007346545000017252 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer.Implementation -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- 'Buffer' implementation, wrapping Rope module Yi.Buffer.Implementation ( UIUpdate (..) , Update (..) , updateIsDelete , Point , Mark, MarkValue (..) , Size , Direction (..) , BufferImpl (mem, marks, markNames, hlCache, overlays, dirtyOffset) , Overlay (..) , mkOverlay , overlayUpdate , applyUpdateI , isValidUpdate , reverseUpdateI , sizeBI , newBI , solPoint , solPoint' , eolPoint' , charsFromSolBI , regexRegionBI , getMarkDefaultPosBI , modifyMarkBI , getMarkValueBI , getMarkBI , newMarkBI , deleteMarkValueBI , setSyntaxBI , addOverlayBI , delOverlayBI , delOverlaysOfOwnerBI , getOverlaysOfOwnerBI , updateSyntax , getAst, focusAst , strokesRangesBI , getStream , getIndexedStream , lineAt , SearchExp , markPointAA , markGravityAA ) where import GHC.Generics (Generic) import Data.Array ((!)) import Data.Binary (Binary (..)) import Data.Function (on) import Data.List (groupBy) import qualified Data.Map.Strict as M (Map, delete, empty, findMax, insert, lookup, map, maxViewWithKey) import Data.Maybe (fromMaybe) import qualified Data.Set as Set (Set, delete, empty, filter, insert, map, toList) import Data.Typeable (Typeable) import Yi.Buffer.Basic (Direction (..), Mark (..), WindowRef, reverseDir) import Yi.Regex (RegexLike (matchAll), SearchExp, searchRegex) import Yi.Region (Region (..), fmapRegion, mkRegion, nearRegion, regionSize) import Yi.Rope (YiString) import qualified Yi.Rope as R import Yi.Style (StyleName, UIStyle (hintStyle, strongHintStyle)) import Yi.Syntax import Yi.Utils (SemiNum ((+~), (~-)), makeLensesWithSuffix, mapAdjust') data MarkValue = MarkValue { markPoint :: !Point , markGravity :: !Direction} deriving (Ord, Eq, Show, Typeable, Generic) makeLensesWithSuffix "AA" ''MarkValue instance Binary MarkValue type Marks = M.Map Mark MarkValue data HLState syntax = forall cache. HLState !(Highlighter cache syntax) !cache data Overlay = Overlay { overlayOwner :: !R.YiString , overlayBegin :: !MarkValue , overlayEnd :: !MarkValue , overlayStyle :: !StyleName , overlayAnnotation :: !R.YiString } instance Eq Overlay where Overlay a b c _ msg == Overlay a' b' c' _ msg' = a == a' && b == b' && c == c' && msg == msg' instance Ord Overlay where compare (Overlay a b c _ msg) (Overlay a' b' c' _ msg') = mconcat [ compare a a' , compare b b' , compare c c' , compare msg msg' ] instance Show Overlay where show (Overlay a b c _ msg) = concat [ "Overlay { " , "overlayOwner = ", show a, ", " , "overlayBegin = ", show b, ", " , "overlayEnd = ", show c, ", " , "overlayAnnotation = ", show msg, "}"] data BufferImpl syntax = FBufferData { mem :: !YiString -- ^ buffer text , marks :: !Marks -- ^ Marks for this buffer , markNames :: !(M.Map String Mark) , hlCache :: !(HLState syntax) -- ^ syntax highlighting state , overlays :: !(Set.Set Overlay) -- ^ set of (non overlapping) visual overlay regions , dirtyOffset :: !Point -- ^ Lowest modified offset since last recomputation of syntax } deriving Typeable dummyHlState :: HLState syntax dummyHlState = HLState noHighlighter (hlStartState noHighlighter) -- Atm we can't store overlays because stylenames are functions (can't be serialized) -- TODO: ideally I'd like to get rid of overlays entirely; although we could imagine them storing mere styles. instance Binary (BufferImpl ()) where put b = put (mem b) >> put (marks b) >> put (markNames b) get = FBufferData <$> get <*> get <*> get <*> pure dummyHlState <*> pure Set.empty <*> pure 0 -- | Mutation actions (also used the undo or redo list) -- -- For the undo/redo, we use the /partial checkpoint/ (Berlage, pg16) strategy to store -- just the components of the state that change. -- -- Note that the update direction is only a hint for moving the cursor -- (mainly for undo purposes); the insertions and deletions are always -- applied Forward. -- -- Note that keeping the text does not cost much: we keep the updates in the undo list; -- if it's a "Delete" it means we have just inserted the text in the buffer, so the update shares -- the data with the buffer. If it's an "Insert" we have to keep the data any way. data Update = Insert { updatePoint :: !Point , updateDirection :: !Direction , _insertUpdateString :: !YiString } | Delete { updatePoint :: !Point , updateDirection :: !Direction , _deleteUpdateString :: !YiString } deriving (Show, Typeable, Generic) instance Binary Update updateIsDelete :: Update -> Bool updateIsDelete Delete {} = True updateIsDelete Insert {} = False updateString :: Update -> YiString updateString (Insert _ _ s) = s updateString (Delete _ _ s) = s updateSize :: Update -> Size updateSize = Size . fromIntegral . R.length . updateString data UIUpdate = TextUpdate !Update | StyleUpdate !Point !Size deriving (Generic) instance Binary UIUpdate -------------------------------------------------- -- Low-level primitives. -- | New FBuffer filled from string. newBI :: YiString -> BufferImpl () newBI s = FBufferData s M.empty M.empty dummyHlState Set.empty 0 -- | Write string into buffer. insertChars :: YiString -> YiString -> Point -> YiString insertChars p cs (Point i) = left `R.append` cs `R.append` right where (left, right) = R.splitAt i p {-# INLINE insertChars #-} -- | Write string into buffer. deleteChars :: YiString -> Point -> Size -> YiString deleteChars p (Point i) (Size n) = left `R.append` right where (left, rest) = R.splitAt i p right = R.drop n rest {-# INLINE deleteChars #-} ------------------------------------------------------------------------ -- Mid-level insert/delete -- | Shift a mark position, supposing an update at a given point, by a given amount. -- Negative amount represent deletions. shiftMarkValue :: Point -> Size -> MarkValue -> MarkValue shiftMarkValue from by (MarkValue p gravity) = MarkValue shifted gravity where shifted | p < from = p | p == from = case gravity of Backward -> p Forward -> p' | otherwise {- p > from -} = p' where p' = max from (p +~ by) mapOvlMarks :: (MarkValue -> MarkValue) -> Overlay -> Overlay mapOvlMarks f (Overlay _owner s e v msg) = Overlay _owner (f s) (f e) v msg ------------------------------------- -- * "high-level" (exported) operations -- | Point of EOF sizeBI :: BufferImpl syntax -> Point sizeBI = Point . R.length . mem -- | Return @n@ Chars starting at @i@ of the buffer. nelemsBI :: Int -> Point -> BufferImpl syntax -> YiString nelemsBI n (Point i) = R.take n . R.drop i . mem getStream :: Direction -> Point -> BufferImpl syntax -> YiString getStream Forward (Point i) = R.drop i . mem getStream Backward (Point i) = R.reverse . R.take i . mem -- | TODO: This guy is a pretty big bottleneck and only one function -- uses it which in turn is only seldom used and most of the output is -- thrown away anyway. We could probably get away with never -- converting this to String here. The old implementation did so -- because it worked over ByteString but we don't have to. getIndexedStream :: Direction -> Point -> BufferImpl syntax -> [(Point,Char)] getIndexedStream Forward (Point p) = zip [Point p..] . R.toString . R.drop p . mem getIndexedStream Backward (Point p) = zip (dF (pred (Point p))) . R.toReverseString . R.take p . mem where dF n = n : dF (pred n) -- | Create an "overlay" for the style @sty@ between points @s@ and @e@ mkOverlay :: R.YiString -> Region -> StyleName -> R.YiString -> Overlay mkOverlay owner r = Overlay owner (MarkValue (regionStart r) Backward) (MarkValue (regionEnd r) Forward) -- | Obtain a style-update for a specific overlay overlayUpdate :: Overlay -> UIUpdate overlayUpdate (Overlay _owner (MarkValue s _) (MarkValue e _) _ _ann) = StyleUpdate s (e ~- s) -- | Add a style "overlay" between the given points. addOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax addOverlayBI ov fb = fb{overlays = Set.insert ov (overlays fb)} -- | Remove a previously added "overlay" delOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax delOverlayBI ov fb = fb{overlays = Set.delete ov (overlays fb)} delOverlaysOfOwnerBI :: R.YiString -> BufferImpl syntax -> BufferImpl syntax delOverlaysOfOwnerBI owner fb = fb{overlays = Set.filter ((/= owner) . overlayOwner) (overlays fb)} getOverlaysOfOwnerBI :: R.YiString -> BufferImpl syntax -> Set.Set Overlay getOverlaysOfOwnerBI owner fb = Set.filter ((== owner) . overlayOwner) (overlays fb) -- FIXME: this can be really inefficient. -- | Return style information for the range @(i,j)@ Style information -- is derived from syntax highlighting, active overlays and current regexp. The -- returned list contains tuples @(l,s,r)@ where every tuple is to -- be interpreted as apply the style @s@ from position @l@ to @r@ in -- the buffer. In each list, the strokes are guaranteed to be -- ordered and non-overlapping. The lists of strokes are ordered by -- decreasing priority: the 1st layer should be "painted" on top. strokesRangesBI :: (Point -> Point -> Point -> [Stroke]) -> Maybe SearchExp -> Region -> Point -> BufferImpl syntax -> [[Stroke]] strokesRangesBI getStrokes regex rgn point fb = result where i = regionStart rgn j = regionEnd rgn dropBefore = dropWhile (\s ->spanEnd s <= i) takeIn = takeWhile (\s -> spanBegin s <= j) groundLayer = [Span i mempty j] -- zero-length spans seem to break stroking in general, so filter them out! syntaxHlLayer = filter (\(Span b _m a) -> b /= a) $ getStrokes point i j layers2 = map (map overlayStroke) $ groupBy ((==) `on` overlayOwner) $ Set.toList $ overlays fb layer3 = case regex of Just re -> takeIn $ map hintStroke $ regexRegionBI re (mkRegion i j) fb Nothing -> [] result = map (map clampStroke . takeIn . dropBefore) (layer3 : layers2 ++ [syntaxHlLayer, groundLayer]) overlayStroke (Overlay _owner sm em a _msg) = Span (markPoint sm) a (markPoint em) clampStroke (Span l x r) = Span (max i l) x (min j r) hintStroke r = Span (regionStart r) (if point `nearRegion` r then strongHintStyle else hintStyle) (regionEnd r) ------------------------------------------------------------------------ -- Point based editing -- | Checks if an Update is valid isValidUpdate :: Update -> BufferImpl syntax -> Bool isValidUpdate u b = case u of (Delete p _ _) -> check p && check (p +~ updateSize u) (Insert p _ _) -> check p where check (Point x) = x >= 0 && x <= R.length (mem b) -- | Apply a /valid/ update applyUpdateI :: Update -> BufferImpl syntax -> BufferImpl syntax applyUpdateI u fb = touchSyntax (updatePoint u) $ fb {mem = p', marks = M.map shift (marks fb), overlays = Set.map (mapOvlMarks shift) (overlays fb)} -- FIXME: this is inefficient; find a way to use mapMonotonic -- (problem is that marks can have different gravities) where (!p', !amount) = case u of Insert pnt _ cs -> (insertChars p cs pnt, sz) Delete pnt _ _ -> (deleteChars p pnt sz, negate sz) !sz = updateSize u shift = shiftMarkValue (updatePoint u) amount p = mem fb -- FIXME: remove collapsed overlays -- | Reverse the given update reverseUpdateI :: Update -> Update reverseUpdateI (Delete p dir cs) = Insert p (reverseDir dir) cs reverseUpdateI (Insert p dir cs) = Delete p (reverseDir dir) cs ------------------------------------------------------------------------ -- Line based editing -- | Line at the given point. (Lines are indexed from 1) lineAt :: Point -- ^ Line for which to grab EOL for -> BufferImpl syntax -> Int lineAt (Point p) fb = 1 + R.countNewLines (R.take p $ mem fb) -- | Point that starts the given line (Lines are indexed from 1) solPoint :: Int -> BufferImpl syntax -> Point solPoint line fb = Point $ R.length $ fst $ R.splitAtLine (line - 1) (mem fb) -- | Point that's at EOL. Notably, this puts you right before the -- newline character if one exists, and right at the end of the text -- if one does not. eolPoint' :: Point -- ^ Point from which we take the line to find the EOL of -> BufferImpl syntax -> Point eolPoint' p@(Point ofs) fb = Point . checkEol . fst . R.splitAtLine ln $ mem fb where ln = lineAt p fb -- In case we're somewhere without trailing newline, we need to -- stay where we are checkEol t = let l' = R.length t in case R.last t of -- We're looking at EOL and we weren't asking for EOL past -- this point, so back up one for good visual effect Just '\n' | l' > ofs -> l' - 1 -- We asked for EOL past the last newline so just go to the -- very end of content _ -> l' -- | Get begining of the line relatively to @point@. solPoint' :: Point -> BufferImpl syntax -> Point solPoint' point fb = solPoint (lineAt point fb) fb charsFromSolBI :: Point -> BufferImpl syntax -> YiString charsFromSolBI pnt fb = nelemsBI (fromIntegral $ pnt - sol) sol fb where sol = solPoint' pnt fb -- | Return indices of all strings in buffer matching regex, inside the given region. regexRegionBI :: SearchExp -> Region -> forall syntax. BufferImpl syntax -> [Region] regexRegionBI se r fb = case dir of Forward -> fmap (fmapRegion addPoint . matchedRegion) $ matchAll' $ R.toString bufReg Backward -> fmap (fmapRegion subPoint . matchedRegion) $ matchAll' $ R.toReverseString bufReg where matchedRegion arr = let (off,len) = arr!0 in mkRegion (Point off) (Point (off+len)) addPoint (Point x) = Point (p + x) subPoint (Point x) = Point (q - x) matchAll' = matchAll (searchRegex dir se) dir = regionDirection r Point p = regionStart r Point q = regionEnd r Size s = regionSize r bufReg = R.take s . R.drop p $ mem fb newMarkBI :: MarkValue -> BufferImpl syntax -> (BufferImpl syntax, Mark) newMarkBI initialValue fb = let maxId = fromMaybe 0 $ markId . fst . fst <$> M.maxViewWithKey (marks fb) newMark = Mark $ maxId + 1 fb' = fb { marks = M.insert newMark initialValue (marks fb)} in (fb', newMark) getMarkValueBI :: Mark -> BufferImpl syntax -> Maybe MarkValue getMarkValueBI m (FBufferData { marks = marksMap } ) = M.lookup m marksMap deleteMarkValueBI :: Mark -> BufferImpl syntax -> BufferImpl syntax deleteMarkValueBI m fb = fb { marks = M.delete m (marks fb) } getMarkBI :: String -> BufferImpl syntax -> Maybe Mark getMarkBI name FBufferData {markNames = nms} = M.lookup name nms -- | Modify a mark value. modifyMarkBI :: Mark -> (MarkValue -> MarkValue) -> (forall syntax. BufferImpl syntax -> BufferImpl syntax) modifyMarkBI m f fb = fb {marks = mapAdjust' f m (marks fb)} -- NOTE: we must insert the value strictly otherwise we can hold to whatever structure the value of the mark depends on. -- (often a whole buffer) setSyntaxBI :: ExtHL syntax -> BufferImpl oldSyntax -> BufferImpl syntax setSyntaxBI (ExtHL e) fb = touchSyntax 0 $ fb {hlCache = HLState e (hlStartState e)} touchSyntax :: Point -> BufferImpl syntax -> BufferImpl syntax touchSyntax touchedIndex fb = fb { dirtyOffset = min touchedIndex (dirtyOffset fb)} updateSyntax :: BufferImpl syntax -> BufferImpl syntax updateSyntax fb@FBufferData {dirtyOffset = touchedIndex, hlCache = HLState hl cache} | touchedIndex == maxBound = fb | otherwise = fb {dirtyOffset = maxBound, hlCache = HLState hl (hlRun hl getText touchedIndex cache) } where getText = Scanner 0 id (error "getText: no character beyond eof") (\idx -> getIndexedStream Forward idx fb) ------------------------------------------------------------------------ -- | Returns the requested mark, creating a new mark with that name (at the supplied position) if needed getMarkDefaultPosBI :: Maybe String -> Point -> BufferImpl syntax -> (BufferImpl syntax, Mark) getMarkDefaultPosBI name defaultPos fb@FBufferData {marks = mks, markNames = nms} = case flip M.lookup nms =<< name of Just m' -> (fb, m') Nothing -> let newMark = Mark (1 + max 1 (markId $ fst (M.findMax mks))) nms' = case name of Nothing -> nms Just nm -> M.insert nm newMark nms mks' = M.insert newMark (MarkValue defaultPos Forward) mks in (fb {marks = mks', markNames = nms'}, newMark) getAst :: WindowRef -> BufferImpl syntax -> syntax getAst w FBufferData {hlCache = HLState (SynHL {hlGetTree = gt}) cache} = gt cache w focusAst :: M.Map WindowRef Region -> BufferImpl syntax -> BufferImpl syntax focusAst r b@FBufferData {hlCache = HLState s@(SynHL {hlFocus = foc}) cache} = b {hlCache = HLState s (foc r cache)} yi-core-0.19.4/src/Yi/Buffer/Indent.hs0000644000000000000000000003475207346545000015516 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer.Region -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Handles indentation in the keymaps. Includes: -- -- * (TODO) Auto-indentation to the previous lines indentation -- * Tab-expansion -- * Shifting of the indentation for a region of text module Yi.Buffer.Indent ( autoIndentB , cycleIndentsB , indentAsNextB , indentAsPreviousB , indentAsTheMostIndentedNeighborLineB , indentOfB , indentOfCurrentPosB , indentSettingsB , indentToB , modifyIndentB , newlineAndIndentB , shiftIndentOfRegionB , tabB ) where import Control.Monad () import Data.Char (isSpace) import Data.List (nub, sort) import Data.Monoid ((<>)) import Yi.Buffer.Basic (Direction (..)) import Yi.Buffer.HighLevel (firstNonSpaceB, getNextLineB, getNextNonBlankLineB, moveToSol, readLnB) import Yi.Buffer.Misc import Yi.Buffer.Region (Region (regionStart), mkRegion, modifyRegionB, readRegionB) import Yi.Buffer.TextUnit (regionWithTwoMovesB) import Yi.Rope (YiString) import qualified Yi.Rope as R import Yi.String (mapLines) {- | Return either a \t or the number of spaces specified by tabSize in the IndentSettings. Note that if you actually want to insert a tab character (for example when editing makefiles) then you should use: @insertB '\t'@. -} tabB :: BufferM String tabB = do indentSettings <- indentSettingsB return $ if expandTabs indentSettings then replicate (tabSize indentSettings) ' ' else "\t" {-| A specialisation of 'autoIndentHelperB'. This is the most basic and the user is encouraged to specialise 'autoIndentHelperB' on their own. -} autoIndentB :: IndentBehaviour -> BufferM () autoIndentB = autoIndentHelperB fetchPreviousIndentsB indentsOfString where -- Returns the indentation hints considering the given -- string as the line above the current one. -- The hints added are: -- The indent of the given string -- The indent of the given string plus two -- The offset of the last open bracket if any in the line. indentsOfString :: YiString -> BufferM [Int] indentsOfString input = do indent <- indentOfB input bracketHints <- lastOpenBracketHint input indentSettings <- indentSettingsB return $ indent : (indent + shiftWidth indentSettings) : bracketHints {-| This takes two arguments the first is a function to obtain indentation hints from lines above the current one. The second is a function to obtain a set of indentation hints from the previous line. Both of these are in the 'BufferM' monad although the second seems like it is unnecessary. However we must take into account the length of tabs which come from the the tab settings and hence we must be in the 'BufferM' monad. To get the straightforward behaviour of the indents of all previous lines until one of them has zero indent call this with: @autoIndentHelperB fetchPreviousIndentsB (fmap (: []) indentOfB)@ However commonly we wish to have something more interesting for the second argument, in particular we commonly wish to have the last opening bracket of the previous line as well as its indent. -} autoIndentHelperB :: BufferM [ Int ] -- ^ Action to fetch hints from previous lines -> (YiString -> BufferM [ Int ]) -- ^ Action to calculate hints from previous line -> IndentBehaviour -- ^ Sets the indent behaviour, -- see 'Yi.Buffer.IndentBehaviour' for a description -> BufferM () autoIndentHelperB getUpwards getPrevious indentBehave = do upwardHints <- savingExcursionB getUpwards previousLine <- getNextLineB Backward previousHints <- getPrevious previousLine let allHints = upwardHints ++ previousHints cycleIndentsB indentBehave allHints -- | Cycles through the indentation hints. It does this without -- requiring to set/get any state. We just look at the current -- indentation of the current line and moving to the largest -- indent that is cycleIndentsB :: IndentBehaviour -> [Int] -> BufferM () cycleIndentsB _ [] = return () cycleIndentsB indentBehave indents = do currentLine <- readLnB currentIndent <- indentOfB currentLine indentToB $ chooseIndent currentIndent (sort $ nub indents) where -- Is the function to choose the indent from the given current -- indent to the given list of indentation hints. chooseIndent :: Int -> [ Int ] -> Int chooseIndent = case indentBehave of IncreaseCycle -> chooseIncreaseCycle DecreaseCycle -> chooseDecreaseCycle IncreaseOnly -> chooseIncreaseOnly DecreaseOnly -> chooseDecreaseOnly -- Choose the indentation hint which is one more than the current -- indentation hint unless the current is the largest or larger than -- all the indentation hints in which case choose the smallest -- (which will often be zero) chooseIncreaseCycle :: Int -> [ Int ] -> Int chooseIncreaseCycle currentIndent hints = -- Similarly to 'chooseDecreasing' if 'above' is null then -- we will go to the first of below which will be the smallest -- indentation hint, if above is not null then we are moving to -- the indentation hint which is one above the current. head (above ++ below) where (below, above) = span (<= currentIndent) hints -- Note that these functions which follow generally assume that -- the list of hints which have been given is already sorted -- and that the list is non-empty -- Choose the indentation hint one less than the current indentation -- unless the current indentation is the smallest (usually zero) -- in which case choose the largest indentation hint. chooseDecreaseCycle :: Int -> [ Int ] -> Int chooseDecreaseCycle currentIndent hints = -- So in particular if 'below' is null then we will -- go to the largest indentation, if below is not null -- we go to the largest indentation which is *not* higher -- than the current one. last (above ++ below) where (below, above) = span (< currentIndent) hints chooseIncreaseOnly :: Int -> [ Int ] -> Int chooseIncreaseOnly currentIndent hints = head $ filter (> currentIndent) hints ++ [ currentIndent ] chooseDecreaseOnly :: Int -> [ Int ] -> Int chooseDecreaseOnly currentIndent hints = last $ currentIndent : filter (< currentIndent) hints {-| A function generally useful as the first argument to 'autoIndentHelperB'. This searches the lines above the current line for the indentations of each line until we get to a line which has no indentation *and* is not empty. Indicating that we have reached the outer scope. -} fetchPreviousIndentsB :: BufferM [Int] fetchPreviousIndentsB = do -- Move up one line, moveOffset <- lineMoveRel (-1) line <- readLnB indent <- indentOfB line -- So if we didn't manage to move upwards -- or the current offset was zero *and* the line -- was non-blank then we return just the current -- indent (it might be the first line but indented some.) if moveOffset == 0 || (indent == 0 && R.any (not . isSpace) line) then return [ indent ] else (indent :) <$> fetchPreviousIndentsB -- | Returns the position of the last opening bracket on the -- line which is not closed on the same line. -- Note that if we have unmatched parentheses such as "( ]" -- then we may not get the correct answer, but in that case -- then arguably we don't really care if we get the correct -- answer (at least if we get it wrong the user may notice -- their error). -- We return a list here as it's a convenient way of returning -- no hint in the case of there being no non-closed bracket -- and normally such a hint will be part of a list of hints -- anyway. -- NOTE: this could be easily modified to return the indentations -- of *all* the non-closed opening brackets. But I think this is -- not what you generally want. -- TODO: we also do not care whether or not the bracket is within -- a string or escaped. If someone feels up to caring about that -- by all means please fix this. lastOpenBracketHint :: YiString -> BufferM [ Int ] lastOpenBracketHint input = case getOpen 0 $ R.reverse input of Nothing -> return [] Just s -> return <$> spacingOfB s where -- We get the last open bracket by counting through -- the reversed line, when we see a closed bracket we -- add one to the count. When we see an opening bracket -- decrease the count. If we see an opening bracket when the -- count is 0 we return the remaining (reversed) string -- as the part of the line which precedes the last opening bracket. -- This can then be turned into an indentation by calling 'spacingOfB' -- on it so that tabs are counted as tab length. -- NOTE: that this will work even if tab occur in the middle of the line getOpen :: Int -> YiString -> Maybe YiString getOpen i s = let rest = R.drop 1 s in case R.head s of Nothing -> Nothing Just c -- If it is opening and we have no closing to match -- then we return the rest of the line | isOpening c && i == 0 -> Just rest -- If i is not zero then we have matched one of the -- closing parentheses and we can decrease the nesting count. | isOpening c -> getOpen (i - 1) rest -- If the character is a closing bracket then we must increase -- the nesting count | isClosing c -> getOpen (i + 1) rest -- If it is just a normal character forget about it and move on. | otherwise -> getOpen i rest isOpening :: Char -> Bool isOpening '(' = True isOpening '[' = True isOpening '{' = True isOpening _ = False isClosing :: Char -> Bool isClosing ')' = True isClosing ']' = True isClosing '}' = True isClosing _ = False -- | Returns the indentation of a given string. Note that this depends -- on the current indentation settings. indentOfB :: YiString -> BufferM Int indentOfB = spacingOfB . R.takeWhile isSpace makeIndentString :: Int -> BufferM YiString makeIndentString level = do IndentSettings et _ sw <- indentSettingsB let (q, r) = level `quotRem` sw if et then return (R.replicate level " ") else return (R.replicate q "\t" <> R.replicate r " ") -- | Returns the length of a given string taking into account the -- white space and the indentation settings. spacingOfB :: YiString -> BufferM Int spacingOfB text = do indentSettings <- indentSettingsB return $ countIndent indentSettings text {-| Indents the current line to the given indentation level. In addition moves the point according to where it was on the line originally. If we were somewhere within the indentation (ie at the start of the line or on an empty line) then we want to just go to the end of the (new) indentation. However if we are currently pointing somewhere within the text of the line then we wish to remain pointing to the same character. -} indentToB :: Int -> BufferM () indentToB = modifyIndentB . const -- | Modifies current line indent measured in visible spaces. -- Respects indent settings. Calling this with value (+ 4) -- will turn "\t" into "\t\t" if shiftwidth is 4 and into -- "\t " if shiftwidth is 8 -- If current line is empty nothing happens. modifyIndentB :: (Int -> Int) -> BufferM () modifyIndentB f = do leadingSpaces <- regionWithTwoMovesB moveToSol firstNonSpaceB newLeadinSpaces <- readRegionB leadingSpaces >>= indentOfB >>= makeIndentString . f modifyRegionB (const newLeadinSpaces) leadingSpaces -- | Indent as much as the previous line indentAsPreviousB :: BufferM () indentAsPreviousB = indentAsNeighborLineB Backward -- | Indent as much as the next line indentAsNextB :: BufferM () indentAsNextB = indentAsNeighborLineB Forward indentAsTheMostIndentedNeighborLineB :: BufferM () indentAsTheMostIndentedNeighborLineB = do prevLine <- getNextNonBlankLineB Backward nextLine <- getNextNonBlankLineB Forward prevIndent <- indentOfB prevLine nextIndent <- indentOfB nextLine indentToB (max prevIndent nextIndent) indentAsNeighborLineB :: Direction -> BufferM () indentAsNeighborLineB dir = do otherLine <- getNextNonBlankLineB dir otherIndent <- indentOfB otherLine indentToB otherIndent -- | Insert a newline at point and indent the new line as the previous one. newlineAndIndentB :: BufferM () newlineAndIndentB = newlineB >> indentAsPreviousB -- | Set the padding of the string to newCount, filling in tabs if -- expandTabs is set in the buffers IndentSettings rePadString :: IndentSettings -> Int -> R.YiString -> R.YiString rePadString indentSettings newCount input | newCount <= 0 = rest | expandTabs indentSettings = R.replicateChar newCount ' ' <> rest | otherwise = tabs <> spaces <> rest where (_indents,rest) = R.span isSpace input tabs = R.replicateChar (newCount `div` tabSize indentSettings) '\t' spaces = R.replicateChar (newCount `mod` tabSize indentSettings) ' ' -- | Counts the size of the indent in the given text. -- -- Assumes nothing but tabs and spaces: uses 'isSpace'. countIndent :: IndentSettings -> R.YiString -> Int countIndent i t = R.foldl' (\i' c -> i' + spacing c) 0 indents where (indents, _) = R.span isSpace t spacing '\t' = tabSize i spacing _ = 1 -- | shifts right (or left if num is negative) num times, filling in tabs if -- expandTabs is set in the buffers IndentSettings indentString :: IndentSettings -> Int -> R.YiString -> R.YiString indentString is numOfShifts i = rePadString is newCount i where newCount = countIndent is i + (shiftWidth is * numOfShifts) -- | Increases the indentation on the region by the given amount of shiftWidth shiftIndentOfRegionB :: Int -> Region -> BufferM () shiftIndentOfRegionB shiftCount region = do is <- indentSettingsB let indentFn :: R.YiString -> R.YiString indentFn line = if not (R.null line) && line /= "\n" then indentString is shiftCount line else line modifyRegionB (mapLines indentFn) region moveTo $ regionStart region firstNonSpaceB -- | Return the number of spaces at the beginning of the line, up to -- the point. indentOfCurrentPosB :: BufferM Int indentOfCurrentPosB = do p <- pointB moveToSol sol <- pointB moveTo p let region = mkRegion p sol readRegionB region >>= spacingOfB yi-core-0.19.4/src/Yi/Buffer/Misc.hs0000644000000000000000000010760207346545000015163 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer.Misc -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- The 'Buffer' module defines monadic editing operations over one-dimensional -- buffers, maintaining a current /point/. module Yi.Buffer.Misc ( FBuffer (FBuffer, bmode) , BufferM (..) , WinMarks, MarkSet (..) , bkey , getMarks , runBuffer , runBufferFull , runBufferDummyWindow , screenTopLn , screenMidLn , screenBotLn , curLn , curCol , colOf , lineOf , lineCountB , sizeB , pointB , pointOfLineColB , solPointB , eolPointB , markLines , moveTo , moveToColB , moveToLineColB , lineMoveRel , lineUp , lineDown , newB , MarkValue (..) , Overlay (overlayAnnotation, overlayBegin, overlayEnd, overlayOwner, overlayStyle) , mkOverlay , gotoLn , gotoLnFrom , leftB , rightB , moveN , leftN , rightN , insertN , insertNAt , insertB , deleteN , nelemsB , writeB , writeN , newlineB , deleteNAt , readB , elemsB , undosA , undoB , redoB , getMarkB , setMarkHereB , setNamedMarkHereB , mayGetMarkB , getMarkValueB , markPointA , modifyMarkB , newMarkB , deleteMarkB , getVisibleSelection , setVisibleSelection , isUnchangedBuffer , setAnyMode , setMode , setMode0 , modifyMode , regexRegionB , regexB , readAtB , getModeLine , getPercent , setInserting , savingPrefCol , forgetPreferCol , movingToPrefCol , movingToPrefVisCol , preferColA , markSavedB , retroactivelyAtSavePointB , addOverlayB , delOverlayB , delOverlaysOfOwnerB , getOverlaysOfOwnerB , isPointInsideOverlay , savingExcursionB , savingPointB , savingPositionB , pendingUpdatesA , highlightSelectionA , rectangleSelectionA , readOnlyA , insertingA , pointFollowsWindowA , revertPendingUpdatesB , askWindow , clearSyntax , focusSyntax , Mode (..) , modeNameA , modeAppliesA , modeHLA , modePrettifyA , modeKeymapA , modeIndentA , modeFollowA , modeIndentSettingsA , modeToggleCommentSelectionA , modeGetStrokesA , modeOnLoadA , modeGotoDeclarationA , modeModeLineA , AnyMode (..) , IndentBehaviour (..) , IndentSettings (..) , expandTabsA , tabSizeA , shiftWidthA , modeAlwaysApplies , modeNeverApplies , emptyMode , withModeB , withMode0 , onMode , withSyntaxB , withSyntaxB' , keymapProcessA , strokesRangesB , streamB , indexedStreamB , askMarks , pointAt , SearchExp , lastActiveWindowA , putBufferDyn , getBufferDyn , shortIdentString , identString , miniIdentString , identA , directoryContentA , BufferId (..) , file , lastSyncTimeA , replaceCharB , replaceCharWithBelowB , replaceCharWithAboveB , insertCharWithBelowB , insertCharWithAboveB , pointAfterCursorB , destinationOfMoveB , withEveryLineB , startUpdateTransactionB , commitUpdateTransactionB , applyUpdate , betweenB , decreaseFontSize , increaseFontSize , indentSettingsB , fontsizeVariationA , stickyEolA , queryBuffer ) where import Prelude hiding (foldr, mapM, notElem) import Control.Applicative (liftA2) import Control.Monad (when, void, replicateM_, join) import Data.Monoid import Control.Monad.Reader import Control.Monad.State.Strict hiding (get, put) import Data.Binary (Binary (..), Get) import Data.Char (ord) import Data.Default (Default (def)) import Data.DynamicState.Serializable (getDyn, putDyn) import Data.Foldable (Foldable (foldr), forM_, notElem) import qualified Data.Map.Strict as M (Map, empty, insert, lookup) import Data.Maybe (fromMaybe, isNothing) import qualified Data.Sequence as S import qualified Data.Set as Set (Set) import qualified Data.Text as T (Text, concat, justifyRight, pack, snoc, unpack) import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8) import Data.Time (UTCTime (UTCTime)) import Data.Traversable (Traversable (mapM), forM) import Lens.Micro.Platform (Lens', lens, (&), (.~), (%~), (^.), use, (.=), (%=), view) import Numeric (showHex) import System.FilePath (joinPath, splitPath) import Yi.Buffer.Basic (BufferRef, Point (..), Size (Size), WindowRef) import Yi.Buffer.Implementation import Yi.Buffer.Undo import Yi.Interact as I (P (End)) import Yi.Monad (getsAndModify, uses) import Yi.Region (Region, mkRegion) import Yi.Rope (YiString) import qualified Yi.Rope as R import Yi.Syntax (ExtHL (ExtHL), Stroke, noHighlighter) import Yi.Types import Yi.Utils (SemiNum ((+~)), makeClassyWithSuffix, makeLensesWithSuffix) import Yi.Window (Window (width, wkey, actualLines), dummyWindow) -- In addition to Buffer's text, this manages (among others): -- * Log of updates mades -- * Undo makeClassyWithSuffix "A" ''Attributes instance HasAttributes FBuffer where attributesA = lens attributes (\(FBuffer f1 f2 _) a -> FBuffer f1 f2 a) -- | Gets a short identifier of a buffer. If we're given a 'MemBuffer' -- then just wraps the buffer name like so: @*name*@. If we're given a -- 'FileBuffer', it drops the number of path components. -- -- >>> let memBuf = newB (BufferRef 0) (MemBuffer "foo/bar/hello") "" -- >>> shortIdentString 2 memBuf -- "*foo/bar/hello*" -- >>> let fileBuf = newB (BufferRef 0) (FileBuffer "foo/bar/hello") "" -- >>> shortIdentString 2 fileBuf -- "hello" shortIdentString :: Int -- ^ Number of characters to drop from FileBuffer names -> FBuffer -- ^ Buffer to work with -> T.Text shortIdentString dl b = case b ^. identA of MemBuffer bName -> "*" <> bName <> "*" FileBuffer fName -> T.pack . joinPath . drop dl $ splitPath fName -- | Gets the buffer's identifier string, emphasising the 'MemBuffer': -- -- >>> let memBuf = newB (BufferRef 0) (MemBuffer "foo/bar/hello") "" -- >>> identString memBuf -- "*foo/bar/hello*" -- >>> let fileBuf = newB (BufferRef 0) (FileBuffer "foo/bar/hello") "" -- >>> identString fileBuf -- "foo/bar/hello" identString :: FBuffer -> T.Text identString b = case b ^. identA of MemBuffer bName -> "*" <> bName <> "*" FileBuffer fName -> T.pack fName -- TODO: proper instance + de-orphan instance Show FBuffer where show b = Prelude.concat [ "Buffer #", show (bkey b) , " (", T.unpack (identString b), ")" ] miniIdentString :: FBuffer -> T.Text miniIdentString b = case b ^. identA of MemBuffer bufName -> bufName FileBuffer _ -> "MINIFILE:" -- unfortunately the dynamic stuff can't be read. instance Binary FBuffer where put (FBuffer binmode r attributes_) = let strippedRaw :: BufferImpl () strippedRaw = setSyntaxBI (modeHL emptyMode) r in do put binmode put strippedRaw put attributes_ get = FBuffer <$> get <*> getStripped <*> get where getStripped :: Get (BufferImpl ()) getStripped = get -- | update the syntax information (clear the dirty "flag") clearSyntax :: FBuffer -> FBuffer clearSyntax = modifyRawbuf updateSyntax queryRawbuf :: (forall syntax. BufferImpl syntax -> x) -> FBuffer -> x queryRawbuf f (FBuffer _ fb _) = f fb modifyRawbuf :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> FBuffer -> FBuffer modifyRawbuf f (FBuffer f1 f2 f3) = FBuffer f1 (f f2) f3 queryAndModifyRawbuf :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> FBuffer -> (FBuffer, x) queryAndModifyRawbuf f (FBuffer f1 f5 f3) = let (f5', x) = f f5 in (FBuffer f1 f5' f3, x) file :: FBuffer -> Maybe FilePath file b = case b ^. identA of FileBuffer f -> Just f MemBuffer _ -> Nothing highlightSelectionA :: Lens' FBuffer Bool highlightSelectionA = selectionStyleA . lens highlightSelection (\e x -> e { highlightSelection = x }) rectangleSelectionA :: Lens' FBuffer Bool rectangleSelectionA = selectionStyleA . lens rectangleSelection (\e x -> e { rectangleSelection = x }) -- | Just stores the mode name. instance Binary (Mode syntax) where put = put . E.encodeUtf8 . modeName get = do n <- E.decodeUtf8 <$> get return (emptyMode {modeName = n}) -- | Increases the font size in the buffer by specified number. What -- this number actually means depends on the front-end. increaseFontSize :: Int -> BufferM () increaseFontSize x = fontsizeVariationA %= \fs -> max 1 (fs + x) -- | Decreases the font size in the buffer by specified number. What -- this number actually means depends on the front-end. decreaseFontSize :: Int -> BufferM () decreaseFontSize x = fontsizeVariationA %= \fs -> max 1 (fs - x) -- | Given a buffer, and some information update the modeline -- -- N.B. the contents of modelines should be specified by user, and -- not hardcoded. getModeLine :: [T.Text] -> BufferM T.Text getModeLine prefix = withModeB (`modeModeLine` prefix) defaultModeLine :: [T.Text] -> BufferM T.Text defaultModeLine prefix = do col <- curCol pos <- pointB ln <- curLn p <- pointB s <- sizeB curChar <- readB ro <-use readOnlyA modeNm <- gets (withMode0 modeName) unchanged <- gets isUnchangedBuffer let pct | pos == 0 || s == 0 = " Top" | pos == s = " Bot" | otherwise = getPercent p s changed = if unchanged then "-" else "*" readOnly' = if ro then "%" else changed hexxed = T.pack $ showHex (ord curChar) "" hexChar = "0x" <> T.justifyRight 2 '0' hexxed toT = T.pack . show nm <- gets $ shortIdentString (length prefix) return $ T.concat [ readOnly', changed, " ", nm , " ", hexChar, " " , "L", T.justifyRight 5 ' ' (toT ln) , " " , "C", T.justifyRight 3 ' ' (toT col) , " ", pct , " ", modeNm , " ", toT $ fromPoint p ] -- | Given a point, and the file size, gives us a percent string getPercent :: Point -> Point -> T.Text getPercent a b = T.justifyRight 3 ' ' (T.pack $ show p) `T.snoc` '%' where p = ceiling (aa / bb * 100.0 :: Double) :: Int aa = fromIntegral a :: Double bb = fromIntegral b :: Double queryBuffer :: (forall syntax. BufferImpl syntax -> x) -> BufferM x queryBuffer x = gets (queryRawbuf x) modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM () modifyBuffer x = modify' (modifyRawbuf x) queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x queryAndModify x = getsAndModify (queryAndModifyRawbuf x) -- | Adds an "overlay" to the buffer addOverlayB :: Overlay -> BufferM () addOverlayB ov = do pendingUpdatesA %= (S.|> overlayUpdate ov) modifyBuffer $ addOverlayBI ov getOverlaysOfOwnerB :: R.YiString -> BufferM (Set.Set Overlay) getOverlaysOfOwnerB owner = queryBuffer (getOverlaysOfOwnerBI owner) -- | Remove an existing "overlay" delOverlayB :: Overlay -> BufferM () delOverlayB ov = do pendingUpdatesA %= (S.|> overlayUpdate ov) modifyBuffer $ delOverlayBI ov delOverlaysOfOwnerB :: R.YiString -> BufferM () delOverlaysOfOwnerB owner = modifyBuffer $ delOverlaysOfOwnerBI owner isPointInsideOverlay :: Point -> Overlay -> Bool isPointInsideOverlay point overlay = let Overlay _ (MarkValue start _) (MarkValue finish _) _ _ = overlay in start <= point && point <= finish -- | Execute a @BufferM@ value on a given buffer and window. The new state of -- the buffer is returned alongside the result of the computation. runBuffer :: Window -> FBuffer -> BufferM a -> (a, FBuffer) runBuffer w b f = let (a, _, b') = runBufferFull w b f in (a, b') getMarks :: Window -> BufferM (Maybe WinMarks) getMarks = gets . getMarksRaw getMarksRaw :: Window -> FBuffer -> Maybe WinMarks getMarksRaw w b = M.lookup (wkey w) (b ^. winMarksA) runBufferFull :: Window -> FBuffer -> BufferM a -> (a, S.Seq Update, FBuffer) runBufferFull w b f = let (a, b') = runState (runReaderT (fromBufferM f') w) b updates = b' ^. updateStreamA -- We're done running BufferM, don't store updates in editor -- state. !newSt = b' & updateStreamA .~ mempty f' = do ms <- getMarks w when (isNothing ms) $ do -- this window has no marks for this buffer yet; have to create them. newMarkValues <- if wkey (b ^. lastActiveWindowA) == def then return -- no previous window, create some marks from scratch. MarkSet { insMark = MarkValue 0 Forward, selMark = MarkValue 0 Backward, -- sel fromMark = MarkValue 0 Backward } -- from else do Just mrks <- uses winMarksA (M.lookup $ wkey (b ^. lastActiveWindowA)) forM mrks getMarkValueB newMrks <- forM newMarkValues newMarkB winMarksA %= M.insert (wkey w) newMrks lastActiveWindowA .= w f in (a, updates, pendingUpdatesA %~ (S.>< fmap TextUpdate updates) $ newSt) getMarkValueRaw :: Mark -> FBuffer -> MarkValue getMarkValueRaw m = fromMaybe (MarkValue 0 Forward) . queryRawbuf (getMarkValueBI m) getMarkValueB :: Mark -> BufferM MarkValue getMarkValueB = gets . getMarkValueRaw newMarkB :: MarkValue -> BufferM Mark newMarkB v = queryAndModify $ newMarkBI v deleteMarkB :: Mark -> BufferM () deleteMarkB m = modifyBuffer $ deleteMarkValueBI m -- | Execute a @BufferM@ value on a given buffer, using a dummy window. The new state of -- the buffer is discarded. runBufferDummyWindow :: FBuffer -> BufferM a -> a runBufferDummyWindow b = fst . runBuffer (dummyWindow $ bkey b) b -- | Mark the current point in the undo list as a saved state. markSavedB :: UTCTime -> BufferM () markSavedB t = do undosA %= setSavedFilePointU lastSyncTimeA .= t bkey :: FBuffer -> BufferRef bkey = view bkey__A isUnchangedBuffer :: FBuffer -> Bool isUnchangedBuffer = isAtSavedFilePointU . view undosA startUpdateTransactionB :: BufferM () startUpdateTransactionB = do transactionPresent <- use updateTransactionInFlightA when (not transactionPresent) $ do undosA %= addChangeU InteractivePoint updateTransactionInFlightA .= True commitUpdateTransactionB :: BufferM () commitUpdateTransactionB = do transactionPresent <- use updateTransactionInFlightA if not transactionPresent then error "Not in update transaction" else do updateTransactionInFlightA .= False transacAccum <- use updateTransactionAccumA updateTransactionAccumA .= mempty undosA %= (appEndo . foldr (<>) mempty) (Endo . addChangeU . AtomicChange <$> transacAccum) undosA %= addChangeU InteractivePoint undoRedo :: (forall syntax. Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, S.Seq Update))) -> BufferM () undoRedo f = do isTransacPresent <- use updateTransactionInFlightA if isTransacPresent then error "Can't undo while undo transaction is in progress" else do m <- getInsMark ur <- use undosA (ur', updates) <- queryAndModify (f m ur) undosA .= ur' updateStreamA %= (<> updates) undoB :: BufferM () undoB = undoRedo undoU redoB :: BufferM () redoB = undoRedo redoU -- | Undo all updates that happened since last save, -- perform a given action and redo all updates again. -- Given action must not modify undo history. retroactivelyAtSavePointB :: BufferM a -> BufferM a retroactivelyAtSavePointB action = do (undoDepth, result) <- go 0 replicateM_ undoDepth redoB return result where go step = do atSavedPoint <- gets isUnchangedBuffer if atSavedPoint then (step,) <$> action else undoB >> go (step + 1) -- | Analogous to const, but returns a function that takes two parameters, -- rather than one. const2 :: t -> t1 -> t2 -> t const2 x _ _ = x -- | Mode applies function that always returns True. modeAlwaysApplies :: a -> b -> Bool modeAlwaysApplies = const2 True -- | Mode applies function that always returns False. modeNeverApplies :: a -> b -> Bool modeNeverApplies = const2 False emptyMode :: Mode syntax emptyMode = Mode { modeName = "empty", modeApplies = modeNeverApplies, modeHL = ExtHL noHighlighter, modePrettify = const $ return (), modeKeymap = id, modeIndent = \_ _ -> return (), modeFollow = const emptyAction, modeIndentSettings = IndentSettings { expandTabs = True , tabSize = 8 , shiftWidth = 4 }, modeToggleCommentSelection = Nothing, modeGetStrokes = \_ _ _ _ -> [], modeOnLoad = return (), modeGotoDeclaration = return (), modeModeLine = defaultModeLine } -- | Create buffer named @nm@ with contents @s@ newB :: BufferRef -> BufferId -> YiString -> FBuffer newB unique nm s = FBuffer { bmode = emptyMode , rawbuf = newBI s , attributes = Attributes { ident = nm , bkey__ = unique , undos = emptyU , preferCol = Nothing , preferVisCol = Nothing , stickyEol = False , bufferDynamic = mempty , pendingUpdates = mempty , selectionStyle = SelectionStyle False False , keymapProcess = I.End , winMarks = M.empty , lastActiveWindow = dummyWindow unique , lastSyncTime = epoch , readOnly = False , directoryContent = False , inserting = True , pointFollowsWindow = mempty , updateTransactionInFlight = False , updateTransactionAccum = mempty , fontsizeVariation = 0 , updateStream = mempty } } epoch :: UTCTime epoch = UTCTime (toEnum 0) (toEnum 0) -- | Point of eof sizeB :: BufferM Point sizeB = queryBuffer sizeBI -- | Extract the current point pointB :: BufferM Point pointB = use . markPointA =<< getInsMark nelemsB :: Int -> Point -> BufferM YiString nelemsB n i = R.take n <$> streamB Forward i streamB :: Direction -> Point -> BufferM YiString streamB dir i = queryBuffer $ getStream dir i indexedStreamB :: Direction -> Point -> BufferM [(Point,Char)] indexedStreamB dir i = queryBuffer $ getIndexedStream dir i strokesRangesB :: Maybe SearchExp -> Region -> BufferM [[Stroke]] strokesRangesB regex r = do p <- pointB getStrokes <- withSyntaxB modeGetStrokes queryBuffer $ strokesRangesBI getStrokes regex r p ------------------------------------------------------------------------ -- Point based operations -- | Move point in buffer to the given index moveTo :: Point -> BufferM () moveTo x = do forgetPreferCol maxP <- sizeB let p = case () of _ | x < 0 -> Point 0 | x > maxP -> maxP | otherwise -> x (.= p) . markPointA =<< getInsMark ------------------------------------------------------------------------ setInserting :: Bool -> BufferM () setInserting = (insertingA .=) checkRO :: BufferM Bool checkRO = do ro <- use readOnlyA when ro (fail "Read Only Buffer") return ro applyUpdate :: Update -> BufferM () applyUpdate update = do runp <- liftA2 (&&) (not <$> checkRO) (queryBuffer (isValidUpdate update)) when runp $ do forgetPreferCol modifyBuffer (applyUpdateI update) isTransacPresent <- use updateTransactionInFlightA if isTransacPresent then updateTransactionAccumA %= (reverseUpdateI update S.<|) else undosA %= addChangeU (AtomicChange $ reverseUpdateI update) updateStreamA %= (S.|> update) -- | Revert all the pending updates; don't touch the point. revertPendingUpdatesB :: BufferM () revertPendingUpdatesB = do updates <- use pendingUpdatesA modifyBuffer $ \stx -> let applyTextUpdate (TextUpdate u) bi = applyUpdateI (reverseUpdateI u) bi applyTextUpdate _ bi = bi in foldr applyTextUpdate stx updates -- | Write an element into the buffer at the current point. writeB :: Char -> BufferM () writeB c = do deleteN 1 insertB c -- | Write the list into the buffer at current point. writeN :: YiString -> BufferM () writeN cs = do off <- pointB deleteNAt Forward (R.length cs) off insertNAt cs off -- | Insert newline at current point. newlineB :: BufferM () newlineB = insertB '\n' ------------------------------------------------------------------------ -- | Insert given 'YiString' at specified point, extending size of the -- buffer. insertNAt :: YiString -> Point -> BufferM () insertNAt rope pnt = applyUpdate (Insert pnt Forward rope) -- | Insert the 'YiString' at current point, extending size of buffer insertN :: YiString -> BufferM () insertN cs = pointB >>= insertNAt cs -- | Insert the char at current point, extending size of buffer -- -- Implementation note: This just 'insertB's a 'R.singleton'. This -- seems sub-optimal because we should be able to do much better -- without spewing chunks of size 1 everywhere. This approach is -- necessary however so an 'Update' can be recorded. A possible -- improvement for space would be to have ‘yi-rope’ package optimise -- for appends with length 1. insertB :: Char -> BufferM () insertB = insertN . R.singleton ------------------------------------------------------------------------ -- | @deleteNAt n p@ deletes @n@ characters forwards from position @p@ deleteNAt :: Direction -> Int -> Point -> BufferM () deleteNAt _ 0 _ = return () deleteNAt dir n pos = do els <- R.take n <$> streamB Forward pos applyUpdate $ Delete pos dir els ------------------------------------------------------------------------ -- Line based editing -- | Return the current line number curLn :: BufferM Int curLn = do p <- pointB queryBuffer (lineAt p) -- | Top line of the screen screenTopLn :: BufferM Int screenTopLn = do p <- use . markPointA =<< fromMark <$> askMarks queryBuffer (lineAt p) -- | Middle line of the screen screenMidLn :: BufferM Int screenMidLn = (+) <$> screenTopLn <*> (div <$> screenLines <*> pure 2) -- | Bottom line of the screen screenBotLn :: BufferM Int screenBotLn = (+) <$> screenTopLn <*> screenLines -- | Amount of lines in the screen screenLines :: BufferM Int screenLines = pred <$> askWindow actualLines -- | Return line numbers of marks markLines :: BufferM (MarkSet Int) markLines = mapM getLn =<< askMarks where getLn m = use (markPointA m) >>= lineOf -- | Go to line number @n@. @n@ is indexed from 1. Returns the -- actual line we went to (which may be not be the requested line, -- if it was out of range) gotoLn :: Int -> BufferM Int gotoLn x = do moveTo 0 succ <$> gotoLnFrom (x - 1) --------------------------------------------------------------------- setMode0 :: forall syntax. Mode syntax -> FBuffer -> FBuffer setMode0 m (FBuffer _ rb at) = FBuffer m (setSyntaxBI (modeHL m) rb) at modifyMode0 :: (forall syntax. Mode syntax -> Mode syntax) -> FBuffer -> FBuffer modifyMode0 f (FBuffer m rb f3) = FBuffer m' (setSyntaxBI (modeHL m') rb) f3 where m' = f m -- | Set the mode setAnyMode :: AnyMode -> BufferM () setAnyMode (AnyMode m) = setMode m setMode :: Mode syntax -> BufferM () setMode m = do modify (setMode0 m) -- reset the keymap process so we use the one of the new mode. keymapProcessA .= I.End modeOnLoad m -- | Modify the mode modifyMode :: (forall syntax. Mode syntax -> Mode syntax) -> BufferM () modifyMode f = do modify (modifyMode0 f) -- reset the keymap process so we use the one of the new mode. keymapProcessA .= I.End onMode :: (forall syntax. Mode syntax -> Mode syntax) -> AnyMode -> AnyMode onMode f (AnyMode m) = AnyMode (f m) withMode0 :: (forall syntax. Mode syntax -> a) -> FBuffer -> a withMode0 f FBuffer {bmode = m} = f m withModeB :: (forall syntax. Mode syntax -> BufferM a) -> BufferM a withModeB x = join (gets (withMode0 x)) withSyntax0 :: (forall syntax. Mode syntax -> syntax -> a) -> WindowRef -> FBuffer -> a withSyntax0 f wk (FBuffer bm rb _attrs) = f bm (getAst wk rb) withSyntaxB :: (forall syntax. Mode syntax -> syntax -> a) -> BufferM a withSyntaxB f = withSyntax0 f <$> askWindow wkey <*> use id focusSyntax :: M.Map WindowRef Region -> FBuffer -> FBuffer focusSyntax r = modifyRawbuf (focusAst r) withSyntaxB' :: (forall syntax. Mode syntax -> syntax -> BufferM a) -> BufferM a withSyntaxB' x = join (withSyntaxB x) -- | Return indices of strings in buffer matched by regex in the -- given region. regexRegionB :: SearchExp -> Region -> BufferM [Region] regexRegionB regex region = queryBuffer $ regexRegionBI regex region -- | Return indices of next string in buffer matched by regex in the -- given direction regexB :: Direction -> SearchExp -> BufferM [Region] regexB dir rx = do p <- pointB s <- sizeB regexRegionB rx (mkRegion p (case dir of Forward -> s; Backward -> 0)) --------------------------------------------------------------------- modifyMarkRaw :: Mark -> (MarkValue -> MarkValue) -> FBuffer -> FBuffer modifyMarkRaw m f = modifyRawbuf $ modifyMarkBI m f modifyMarkB :: Mark -> (MarkValue -> MarkValue) -> BufferM () modifyMarkB = (modify .) . modifyMarkRaw setMarkHereB :: BufferM Mark setMarkHereB = getMarkB Nothing setNamedMarkHereB :: String -> BufferM () setNamedMarkHereB name = do p <- pointB getMarkB (Just name) >>= (.= p) . markPointA -- | Highlight the selection setVisibleSelection :: Bool -> BufferM () setVisibleSelection = (highlightSelectionA .=) -- | Whether the selection is highlighted getVisibleSelection :: BufferM Bool getVisibleSelection = use highlightSelectionA getInsMark :: BufferM Mark getInsMark = insMark <$> askMarks askMarks :: BufferM WinMarks askMarks = do Just !ms <- getMarks =<< ask return ms getMarkB :: Maybe String -> BufferM Mark getMarkB m = do p <- pointB queryAndModify (getMarkDefaultPosBI m p) mayGetMarkB :: String -> BufferM (Maybe Mark) mayGetMarkB m = queryBuffer (getMarkBI m) -- | Move point by the given number of characters. -- A negative offset moves backwards a positive one forward. moveN :: Int -> BufferM () moveN n = do s <- sizeB moveTo =<< min s . max 0 . (+~ Size n) <$> pointB -- | Move point -1 leftB :: BufferM () leftB = leftN 1 -- | Move cursor -n leftN :: Int -> BufferM () leftN n = moveN (-n) -- | Move cursor +1 rightB :: BufferM () rightB = rightN 1 -- | Move cursor +n rightN :: Int -> BufferM () rightN = moveN -- --------------------------------------------------------------------- -- Line based movement and friends -- | Move point down by @n@ lines. @n@ can be negative. -- Returns the actual difference in lines which we moved which -- may be negative if the requested line difference is negative. lineMoveRel :: Int -> BufferM Int lineMoveRel = movingToPrefCol . gotoLnFrom movingToPrefCol :: BufferM a -> BufferM a movingToPrefCol f = do prefCol <- use preferColA targetCol <- maybe curCol return prefCol r <- f moveToColB targetCol preferColA .= Just targetCol return r -- | Moves to a visual column within the current line as shown -- on the editor (ie, moving within the current width of a -- single visual line) movingToPrefVisCol :: BufferM a -> BufferM a movingToPrefVisCol f = do prefCol <- use preferVisColA targetCol <- maybe curVisCol return prefCol r <- f moveToVisColB targetCol preferVisColA .= Just targetCol return r moveToColB :: Int -> BufferM () moveToColB targetCol = do solPnt <- solPointB =<< pointB chrs <- R.toString <$> nelemsB targetCol solPnt is <- indentSettingsB let cols = scanl (colMove is) 0 chrs -- columns corresponding to the char toSkip = takeWhile (\(char,col) -> char /= '\n' && col < targetCol) (zip chrs cols) moveTo $ solPnt +~ fromIntegral (length toSkip) moveToVisColB :: Int -> BufferM () moveToVisColB targetCol = do col <- curCol wid <- width <$> use lastActiveWindowA let jumps = col `div` wid moveToColB $ jumps * wid + targetCol moveToLineColB :: Int -> Int -> BufferM () moveToLineColB line col = gotoLn line >> moveToColB col pointOfLineColB :: Int -> Int -> BufferM Point pointOfLineColB line col = savingPointB $ moveToLineColB line col >> pointB forgetPreferCol :: BufferM () forgetPreferCol = do preferColA .= Nothing preferVisColA .= Nothing !st <- gets id return $! (st `seq` ()) savingPrefCol :: BufferM a -> BufferM a savingPrefCol f = do pc <- use preferColA pv <- use preferVisColA result <- f preferColA .= pc preferVisColA .= pv return result -- | Move point up one line lineUp :: BufferM () lineUp = void (lineMoveRel (-1)) -- | Move point down one line lineDown :: BufferM () lineDown = void (lineMoveRel 1) -- | Return the contents of the buffer. elemsB :: BufferM YiString elemsB = queryBuffer mem -- | Returns the contents of the buffer between the two points. -- -- If the @startPoint >= endPoint@, empty string is returned. If the -- points are out of bounds, as much of the content as possible is -- taken: you're not guaranteed to get @endPoint - startPoint@ -- characters. betweenB :: Point -- ^ Point to start at -> Point -- ^ Point to stop at -> BufferM YiString betweenB (Point s) (Point e) = if s >= e then return (mempty :: YiString) else snd . R.splitAt s . fst . R.splitAt e <$> elemsB -- | Read the character at the current point readB :: BufferM Char readB = pointB >>= readAtB -- | Read the character at the given index -- This is an unsafe operation: character NUL is returned when out of bounds readAtB :: Point -> BufferM Char readAtB i = R.head <$> nelemsB 1 i >>= return . \case Nothing -> '\0' Just c -> c replaceCharB :: Char -> BufferM () replaceCharB c = do writeB c leftB replaceCharWithBelowB :: BufferM () replaceCharWithBelowB = replaceCharWithVerticalOffset 1 replaceCharWithAboveB :: BufferM () replaceCharWithAboveB = replaceCharWithVerticalOffset (-1) insertCharWithBelowB :: BufferM () insertCharWithBelowB = maybe (return ()) insertB =<< maybeCharBelowB insertCharWithAboveB :: BufferM () insertCharWithAboveB = maybe (return ()) insertB =<< maybeCharAboveB replaceCharWithVerticalOffset :: Int -> BufferM () replaceCharWithVerticalOffset offset = maybe (return ()) replaceCharB =<< maybeCharWithVerticalOffset offset maybeCharBelowB :: BufferM (Maybe Char) maybeCharBelowB = maybeCharWithVerticalOffset 1 maybeCharAboveB :: BufferM (Maybe Char) maybeCharAboveB = maybeCharWithVerticalOffset (-1) maybeCharWithVerticalOffset :: Int -> BufferM (Maybe Char) maybeCharWithVerticalOffset offset = savingPointB $ do l0 <- curLn c0 <- curCol void $ lineMoveRel offset l1 <- curLn c1 <- curCol curChar <- readB return $ if c0 == c1 && l0 + offset == l1 && curChar `notElem` ("\n\0" :: String) then Just curChar else Nothing -- | Delete @n@ characters forward from the current point deleteN :: Int -> BufferM () deleteN n = pointB >>= deleteNAt Forward n ------------------------------------------------------------------------ -- | Gives the 'IndentSettings' for the current buffer. indentSettingsB :: BufferM IndentSettings indentSettingsB = withModeB $ return . modeIndentSettings -- | Current column. -- Note that this is different from offset or number of chars from sol. -- (This takes into account tabs, unicode chars, etc.) curCol :: BufferM Int curCol = colOf =<< pointB -- | Current column, visually. curVisCol :: BufferM Int curVisCol = rem <$> curCol <*> (width <$> use lastActiveWindowA) colOf :: Point -> BufferM Int colOf p = do is <- indentSettingsB R.foldl' (colMove is) 0 <$> queryBuffer (charsFromSolBI p) lineOf :: Point -> BufferM Int lineOf p = queryBuffer $ lineAt p lineCountB :: BufferM Int lineCountB = lineOf =<< sizeB -- | Decides which column we should be on after the given character. colMove :: IndentSettings -> Int -> Char -> Int colMove is col '\t' | tabSize is > 1 = col + tabSize is colMove _ col _ = col + 1 -- | Returns start of line point for a given point @p@ solPointB :: Point -> BufferM Point solPointB p = queryBuffer $ solPoint' p -- | Returns end of line for given point. eolPointB :: Point -> BufferM Point eolPointB p = queryBuffer $ eolPoint' p -- | Go to line indexed from current point -- Returns the actual moved difference which of course -- may be negative if the requested difference was negative. gotoLnFrom :: Int -> BufferM Int gotoLnFrom x = do l <- curLn p' <- queryBuffer $ solPoint (l + x) moveTo p' l' <- curLn return (l' - l) -- | Access to a value into the extensible state, keyed by its type. -- This allows you to retrieve inside a 'BufferM' monad, ie: -- -- > value <- getBufferDyn getBufferDyn :: forall m a. (Default a, YiVariable a, MonadState FBuffer m, Functor m) => m a getBufferDyn = fromMaybe (def :: a) <$> getDyn (use bufferDynamicA) (bufferDynamicA .=) -- | Access to a value into the extensible state, keyed by its type. -- This allows you to save inside a 'BufferM' monad, ie: -- -- > putBufferDyn updatedvalue putBufferDyn :: (YiVariable a, MonadState FBuffer m, Functor m) => a -> m () putBufferDyn = putDyn (use bufferDynamicA) (bufferDynamicA .=) -- | perform a @BufferM a@, and return to the current point. (by using a mark) savingExcursionB :: BufferM a -> BufferM a savingExcursionB f = do m <- getMarkB Nothing res <- f moveTo =<< use (markPointA m) return res markPointA :: forall f . Functor f => Mark -> (Point -> f Point) -> (FBuffer -> f FBuffer) markPointA mark = lens getter setter where getter b = markPoint $ getMarkValueRaw mark b setter b pos = modifyMarkRaw mark (\v -> v {markPoint = pos}) b -- | Perform an @BufferM a@, and return to the current point. savingPointB :: BufferM a -> BufferM a savingPointB f = savingPrefCol $ do p <- pointB res <- f moveTo p return res -- | Perform an @BufferM a@, and return to the current line and column -- number. The difference between this and 'savingPointB' is that here -- we attempt to return to the specific line and column number, rather -- than a specific number of characters from the beginning of the -- buffer. -- -- In case the column is further away than EOL, the point is left at -- EOL: 'moveToLineColB' is used internally. savingPositionB :: BufferM a -> BufferM a savingPositionB f = savingPrefCol $ do (c, l) <- (,) <$> curCol <*> curLn res <- f moveToLineColB l c return res pointAt :: BufferM a -> BufferM Point pointAt f = savingPointB (f *> pointB) pointAfterCursorB :: Point -> BufferM Point pointAfterCursorB p = pointAt $ do moveTo p rightB -- | What would be the point after doing the given action? -- The argument must not modify the buffer. destinationOfMoveB :: BufferM a -> BufferM Point destinationOfMoveB f = savingPointB (f >> pointB) ------------- -- Window askWindow :: (Window -> a) -> BufferM a askWindow = asks withEveryLineB :: BufferM () -> BufferM () withEveryLineB action = savingPointB $ do lineCount <- lineCountB forM_ [1 .. lineCount] $ \l -> do void $ gotoLn l action makeLensesWithSuffix "A" ''IndentSettings makeLensesWithSuffix "A" ''Mode yi-core-0.19.4/src/Yi/Buffer/Normal.hs0000644000000000000000000001021307346545000015507 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | A normalized API to many buffer operations. -- The idea is that most operations should be parametric in both -- * the textual units they work on -- * the direction towards which they operate (if applicable) module Yi.Buffer.Normal ( TextUnit(Character, Line, VLine, Document, GenUnit) , isAnySep , isWordChar , leftBoundaryUnit , outsideUnit , unitDelimited , unitEmacsParagraph , unitParagraph , unitSentence , unitSep , unitSepThisLine , unitViWORD , unitViWORDAnyBnd , unitViWORDOnLine , unitViWord , unitViWordAnyBnd , unitViWordOnLine , unitWord -- TextUnit is exported abstract intentionally: -- we'd like to move more units to the GenUnit format. , atBoundaryB , deleteB , doIfCharB , doUntilB_ , genMaybeMoveB , genMoveB , maybeMoveB , moveB , numberOfB , readPrevUnitB , readUnitB , regionOfB , regionOfNonEmptyB , regionOfPartB , regionOfPartNonEmptyAtB , regionOfPartNonEmptyB , transformB , transposeB , untilB , untilB_ , whileB , BoundarySide(..) , checkPeekB , genAtBoundaryB , genEnclosingUnit , genUnitBoundary , RegionStyle(..) , convertRegionToStyleB , extendRegionToBoundaries , getRegionStyle , mkRegionOfStyleB , putRegionStyle , unitWiseRegion ) where import Data.List (sort) import Yi.Buffer.Basic (Direction (Backward, Forward), Point) import Yi.Buffer.Misc (BufferM, getBufferDyn, moveTo, pointB, putBufferDyn, savingPointB) import Yi.Buffer.Region (Region (..), inclusiveRegionB, mkRegion, mkRegion') import Yi.Buffer.TextUnit import Yi.Types (RegionStyle (..)) getRegionStyle :: BufferM RegionStyle getRegionStyle = getBufferDyn putRegionStyle :: RegionStyle -> BufferM () putRegionStyle = putBufferDyn convertRegionToStyleB :: Region -> RegionStyle -> BufferM Region convertRegionToStyleB r = mkRegionOfStyleB (regionStart r) (regionEnd r) mkRegionOfStyleB :: Point -> Point -> RegionStyle -> BufferM Region mkRegionOfStyleB start' stop' regionStyle = let [start, stop] = sort [start', stop'] region = mkRegion start stop in case regionStyle of LineWise -> inclusiveRegionB =<< unitWiseRegion Line region Inclusive -> inclusiveRegionB region Exclusive -> return region Block -> return region unitWiseRegion :: TextUnit -> Region -> BufferM Region unitWiseRegion unit = extendRegionToBoundaries unit InsideBound OutsideBound -- | Extend the given region to boundaries of the text unit. -- For instance one can extend the selection to complete lines, or -- paragraphs. extendRegionToBoundaries :: TextUnit -> BoundarySide -> BoundarySide -> Region -> BufferM Region extendRegionToBoundaries unit bs1 bs2 region = savingPointB $ do moveTo $ regionStart region genMaybeMoveB unit (Backward, bs1) Backward start <- pointB moveTo $ regionEnd region genMaybeMoveB unit (Forward, bs2) Forward stop <- pointB return $ mkRegion' (regionDirection region) start stop yi-core-0.19.4/src/Yi/Buffer/Region.hs0000644000000000000000000001174707346545000015517 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer.Region -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- This module defines buffer operation on regions module Yi.Buffer.Region ( module Yi.Region , swapRegionsB , deleteRegionB , replaceRegionB , readRegionB , mapRegionB , modifyRegionB , winRegionB , inclusiveRegionB , blockifyRegion , joinLinesB , concatLinesB , linesOfRegionB ) where import Control.Monad (when) import Data.Char (isSpace) import Data.List (sort) import Yi.Buffer.Misc import Yi.Region import Yi.Rope (YiString) import qualified Yi.Rope as R (YiString, cons, dropWhile, filter , lines, lines', map, null, length) import Yi.String (overInit) import Yi.Utils (SemiNum ((~-))) import Yi.Window (winRegion) winRegionB :: BufferM Region winRegionB = askWindow winRegion -- | Delete an arbitrary part of the buffer deleteRegionB :: Region -> BufferM () deleteRegionB r = deleteNAt (regionDirection r) (fromIntegral (regionEnd r ~- regionStart r)) (regionStart r) readRegionB :: Region -> BufferM YiString readRegionB r = nelemsB (fromIntegral (regionEnd r - i)) i where i = regionStart r -- | Replace a region with a given rope. replaceRegionB :: Region -> YiString -> BufferM () replaceRegionB r s = do deleteRegionB r insertNAt s $ regionStart r -- | Map the given function over the characters in the region. mapRegionB :: Region -> (Char -> Char) -> BufferM () mapRegionB r f = do text <- readRegionB r replaceRegionB r (R.map f text) -- | Swap the content of two Regions swapRegionsB :: Region -> Region -> BufferM () swapRegionsB r r' | regionStart r > regionStart r' = swapRegionsB r' r | otherwise = do w0 <- readRegionB r w1 <- readRegionB r' replaceRegionB r' w0 replaceRegionB r w1 -- | Modifies the given region according to the given -- string transformation function modifyRegionB :: (R.YiString -> R.YiString) -- ^ The string modification function -> Region -- ^ The region to modify -> BufferM () modifyRegionB f region = f <$> readRegionB region >>= replaceRegionB region -- | Extend the right bound of a region to include it. inclusiveRegionB :: Region -> BufferM Region inclusiveRegionB r = if regionStart r <= regionEnd r then mkRegion (regionStart r) <$> pointAfterCursorB (regionEnd r) else mkRegion <$> pointAfterCursorB (regionStart r) <*> pure (regionEnd r) -- | See a region as a block/rectangular region, -- since regions are represented by two point, this returns -- a list of small regions form this block region. blockifyRegion :: Region -> BufferM [Region] blockifyRegion r = savingPointB $ do [lowCol, highCol] <- sort <$> mapM colOf [regionStart r, regionEnd r] startLine <- lineOf $ regionStart r endLine <- lineOf $ regionEnd r when (startLine > endLine) $ fail "blockifyRegion: impossible" mapM (\line -> mkRegion <$> pointOfLineColB line lowCol <*> pointOfLineColB line (1 + highCol)) [startLine..endLine] -- | Joins lines in the region with a single space, skipping any empty -- lines. joinLinesB :: Region -> BufferM () joinLinesB = savingPointB . modifyRegionB g' where g' = overInit $ mconcat . pad . R.lines pad :: [R.YiString] -> [R.YiString] pad [] = [] pad (x:xs) = x : fmap (skip (R.cons ' ' . R.dropWhile isSpace)) xs skip g x = if R.null x then x else g x -- | Concatenates lines in the region preserving the trailing newline -- if any. concatLinesB :: Region -> BufferM () concatLinesB = savingPointB . modifyRegionB (overInit $ R.filter (/= '\n')) -- | Gets the lines of a region (as a region), preserving newlines. Thus the -- resulting list of regions is a partition of the original region. -- -- The direction of the region is preserved and all smaller regions will -- retain that direction. -- -- Note that regions should never be empty, so it would be odd for this to -- return an empty list... linesOfRegionB :: Region -> BufferM [Region] linesOfRegionB region = do let start = regionStart region direction = regionDirection region ls <- R.lines' <$> readRegionB region return $ case ls of [] -> [] (l:ls') -> let initialRegion = mkRegion' direction start (start + fromIntegral (R.length l)) in scanl nextRegion initialRegion ls' -- | Given some text and the previous region, finds the next region -- (used for implementing linesOfRegionB, not generally useful) nextRegion :: Region -> R.YiString -> Region nextRegion r l = mkRegion' (regionDirection r) (regionEnd r) (regionEnd r + len) where len = fromIntegral $ R.length l yi-core-0.19.4/src/Yi/Buffer/TextUnit.hs0000644000000000000000000004161507346545000016055 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Buffer.TextUnit -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Working with blocks (units) of text. -- module Yi.Buffer.TextUnit ( TextUnit(..) , outsideUnit , leftBoundaryUnit , unitWord , unitViWord , unitViWORD , unitViWordAnyBnd , unitViWORDAnyBnd , unitViWordOnLine , unitViWORDOnLine , unitDelimited , unitSentence, unitEmacsParagraph, unitParagraph , isAnySep, unitSep, unitSepThisLine, isWordChar , moveB, maybeMoveB , transformB, transposeB , regionOfB, regionOfNonEmptyB, regionOfPartB , regionWithTwoMovesB , regionOfPartNonEmptyB, regionOfPartNonEmptyAtB , readPrevUnitB, readUnitB , untilB, doUntilB_, untilB_, whileB, doIfCharB , atBoundaryB , numberOfB , deleteB, genMaybeMoveB , genMoveB, BoundarySide(..), genAtBoundaryB , checkPeekB , halfUnit , deleteUnitB ) where import Control.Monad (void, when, (<=<)) import Data.Char (GeneralCategory (LineSeparator, ParagraphSeparator, Space), generalCategory, isAlphaNum, isSeparator, isSpace) import Data.Typeable (Typeable) import Yi.Buffer.Basic (Direction (..), Point (Point), mayReverse, reverseDir) import Yi.Buffer.Misc import Yi.Buffer.Region import Yi.Rope (YiString) import qualified Yi.Rope as R (head, reverse, tail, toString) -- | Designate a given "unit" of text. data TextUnit = Character -- ^ a single character | Line -- ^ a line of text (between newlines) | VLine -- ^ a "vertical" line of text (area of text between two characters at the same column number) | Document -- ^ the whole document | GenUnit {genEnclosingUnit :: TextUnit, genUnitBoundary :: Direction -> BufferM Bool} -- there could be more text units, like Page, Searched, etc. it's probably a good -- idea to use GenUnit though. deriving Typeable -- | Turns a unit into its "negative" by inverting the boundaries. For example, -- @outsideUnit unitViWord@ will be the unit of spaces between words. For units -- without boundaries ('Character', 'Document', ...), this is the identity -- function. outsideUnit :: TextUnit -> TextUnit outsideUnit (GenUnit enclosing boundary) = GenUnit enclosing (boundary . reverseDir) outsideUnit x = x -- for a lack of better definition -- | Common boundary checking function: run the condition on @len@ -- characters in specified direction shifted by specified offset. genBoundary :: Int -- ^ Offset from current position -> Int -- ^ Look-ahead -> (YiString -> Bool) -- ^ predicate -> Direction -- ^ Direction to look in -> BufferM Bool genBoundary ofs len condition dir = condition <$> peekB where peekB = do Point p' <- pointB let pt@(Point p) = Point (p' + mayNegate ofs) case dir of Forward -> betweenB pt (Point $ max 0 p + len) Backward -> R.reverse <$> betweenB (Point $ p - len) pt mayNegate = case dir of Forward -> id Backward -> negate -- | a word as in use in Emacs (fundamental mode) unitWord :: TextUnit unitWord = GenUnit Document $ \direction -> checkPeekB (-1) [isWordChar, not . isWordChar] direction -- | delimited on the left and right by given characters, boolean -- argument tells if whether those are included. unitDelimited :: Char -> Char -> Bool -> TextUnit unitDelimited left right included = GenUnit Document $ \direction -> case (included,direction) of (False, Backward) -> do isCursorOnLeftChar <- (== left) <$> readB when isCursorOnLeftChar rightB checkPeekB 0 [(== left)] Backward (False, Forward) -> do isCursorOnRightChar <- (== right) <$> readB isTextUnitBlank <- checkPeekB 0 [(== left)] Backward if isTextUnitBlank && isCursorOnRightChar then leftB >> return True else return isCursorOnRightChar (True, Backward) -> checkPeekB 0 [(== left)] Forward (True, Forward) -> rightB >> checkPeekB 0 [(== right)] Backward isWordChar :: Char -> Bool isWordChar x = isAlphaNum x || x == '_' isNl :: Char -> Bool isNl = (== '\n') -- | Tells if a char can end a sentence ('.', '!', '?'). isEndOfSentence :: Char -> Bool isEndOfSentence = (`elem` ".!?") -- | Verifies that the string matches all the predicates, pairwise. If -- the string is "too small", then return 'False'. Note the length of -- predicates has to be finite. checks :: [Char -> Bool] -> YiString -> Bool checks ps' t' = go ps' (R.toString t') where go [] _ = True go _ [] = False go (p:ps) (x:xs) = p x && go ps xs checkPeekB :: Int -> [Char -> Bool] -> Direction -> BufferM Bool checkPeekB offset conds = genBoundary offset (length conds) (checks conds) -- | Helper that takes first two characters of YiString. Faster than -- take 2 and string conversion. firstTwo :: YiString -> Maybe (Char, Char) firstTwo t = case R.head t of Nothing -> Nothing Just c -> case R.tail t >>= R.head of Nothing -> Nothing Just c' -> Just (c, c') atViWordBoundary :: (Char -> Int) -> Direction -> BufferM Bool atViWordBoundary charType = genBoundary (-1) 2 $ \cs -> case firstTwo cs of Just (c1, c2) -> isNl c1 && isNl c2 -- stop at empty lines || not (isSpace c1) && (charType c1 /= charType c2) Nothing -> True atAnyViWordBoundary :: (Char -> Int) -> Direction -> BufferM Bool atAnyViWordBoundary charType = genBoundary (-1) 2 $ \cs -> case firstTwo cs of Just (c1, c2) -> isNl c1 || isNl c2 || charType c1 /= charType c2 Nothing -> True atViWordBoundaryOnLine :: (Char -> Int) -> Direction -> BufferM Bool atViWordBoundaryOnLine charType = genBoundary (-1) 2 $ \cs -> case firstTwo cs of Just (c1, c2)-> isNl c1 || isNl c2 || not (isSpace c1) && charType c1 /= charType c2 Nothing -> True unitViWord :: TextUnit unitViWord = GenUnit Document $ atViWordBoundary viWordCharType unitViWORD :: TextUnit unitViWORD = GenUnit Document $ atViWordBoundary viWORDCharType unitViWordAnyBnd :: TextUnit unitViWordAnyBnd = GenUnit Document $ atAnyViWordBoundary viWordCharType unitViWORDAnyBnd :: TextUnit unitViWORDAnyBnd = GenUnit Document $ atAnyViWordBoundary viWORDCharType unitViWordOnLine :: TextUnit unitViWordOnLine = GenUnit Document $ atViWordBoundaryOnLine viWordCharType unitViWORDOnLine :: TextUnit unitViWORDOnLine = GenUnit Document $ atViWordBoundaryOnLine viWORDCharType viWordCharType :: Char -> Int viWordCharType c | isSpace c = 1 | isWordChar c = 2 | otherwise = 3 viWORDCharType :: Char -> Int viWORDCharType c | isSpace c = 1 | otherwise = 2 -- | Separator characters (space, tab, unicode separators). Most of -- the units above attempt to identify "words" with various -- punctuation and symbols included or excluded. This set of units is -- a simple inverse: it is true for "whitespace" or "separators" and -- false for anything that is not (letters, numbers, symbols, -- punctuation, whatever). isAnySep :: Char -> Bool isAnySep c = isSeparator c || isSpace c || generalCategory c `elem` seps where seps = [ Space, LineSeparator, ParagraphSeparator ] atSepBoundary :: Direction -> BufferM Bool atSepBoundary = genBoundary (-1) 2 $ \cs -> case firstTwo cs of Just (c1, c2) -> isNl c1 || isNl c2 || isAnySep c1 /= isAnySep c2 Nothing -> True -- | unitSep is true for any kind of whitespace/separator unitSep :: TextUnit unitSep = GenUnit Document atSepBoundary -- | unitSepThisLine is true for any kind of whitespace/separator on this line only unitSepThisLine :: TextUnit unitSepThisLine = GenUnit Line atSepBoundary -- | Is the point at a @Unit@ boundary in the specified @Direction@? atBoundary :: TextUnit -> Direction -> BufferM Bool atBoundary Document Backward = (== 0) <$> pointB atBoundary Document Forward = (>=) <$> pointB <*> sizeB atBoundary Character _ = return True atBoundary VLine _ = return True -- a fallacy; this needs a little refactoring. atBoundary Line direction = checkPeekB 0 [isNl] direction atBoundary (GenUnit _ atBound) dir = atBound dir enclosingUnit :: TextUnit -> TextUnit enclosingUnit (GenUnit enclosing _) = enclosing enclosingUnit _ = Document atBoundaryB :: TextUnit -> Direction -> BufferM Bool atBoundaryB Document d = atBoundary Document d atBoundaryB u d = (||) <$> atBoundary u d <*> atBoundaryB (enclosingUnit u) d -- | Paragraph to implement emacs-like forward-paragraph/backward-paragraph unitEmacsParagraph :: TextUnit unitEmacsParagraph = GenUnit Document $ checkPeekB (-2) [not . isNl, isNl, isNl] -- | Paragraph that begins and ends in the paragraph, not the empty lines surrounding it. unitParagraph :: TextUnit unitParagraph = GenUnit Document $ checkPeekB (-1) [not . isNl, isNl, isNl] unitSentence :: TextUnit unitSentence = GenUnit unitEmacsParagraph $ \dir -> checkPeekB (if dir == Forward then -1 else 0) (mayReverse dir [isEndOfSentence, isSpace]) dir -- | Unit that have its left and right boundaries at the left boundary of the argument unit. leftBoundaryUnit :: TextUnit -> TextUnit leftBoundaryUnit u = GenUnit Document (\_dir -> atBoundaryB u Backward) -- | @genAtBoundaryB u d s@ returns whether the point is at a given boundary @(d,s)@ . -- Boundary @(d,s)@ , taking Word as example, means: -- Word -- ^^ ^^ -- 12 34 -- 1: (Backward,OutsideBound) -- 2: (Backward,InsideBound) -- 3: (Forward,InsideBound) -- 4: (Forward,OutsideBound) -- -- rules: -- genAtBoundaryB u Backward InsideBound = atBoundaryB u Backward -- genAtBoundaryB u Forward OutsideBound = atBoundaryB u Forward genAtBoundaryB :: TextUnit -> Direction -> BoundarySide -> BufferM Bool genAtBoundaryB u d s = withOffset (off u d s) $ atBoundaryB u d where withOffset 0 f = f withOffset ofs f = savingPointB (((ofs +) <$> pointB) >>= moveTo >> f) off _ Backward InsideBound = 0 off _ Backward OutsideBound = 1 off _ Forward InsideBound = 1 off _ Forward OutsideBound = 0 numberOfB :: TextUnit -> TextUnit -> BufferM Int numberOfB unit containingUnit = savingPointB $ do maybeMoveB containingUnit Backward start <- pointB moveB containingUnit Forward end <- pointB moveTo start length <$> untilB ((>= end) <$> pointB) (moveB unit Forward) whileB :: BufferM Bool -> BufferM a -> BufferM [a] whileB cond = untilB (not <$> cond) -- | Repeat an action until the condition is fulfilled or the cursor -- stops moving. The Action may be performed zero times. untilB :: BufferM Bool -> BufferM a -> BufferM [a] untilB cond f = do stop <- cond if stop then return [] else doUntilB cond f -- | Repeat an action until the condition is fulfilled or the cursor -- stops moving. The Action is performed at least once. doUntilB :: BufferM Bool -> BufferM a -> BufferM [a] doUntilB cond f = loop where loop = do p <- pointB x <- f p' <- pointB stop <- cond (x:) <$> if p /= p' && not stop then loop else return [] doUntilB_ :: BufferM Bool -> BufferM a -> BufferM () doUntilB_ cond f = void (doUntilB cond f) -- maybe do an optimized version? untilB_ :: BufferM Bool -> BufferM a -> BufferM () untilB_ cond f = void (untilB cond f) -- maybe do an optimized version? -- | Do an action if the current buffer character passes the predicate doIfCharB :: (Char -> Bool) -> BufferM a -> BufferM () doIfCharB p o = readB >>= \c -> when (p c) $ void o -- | Boundary side data BoundarySide = InsideBound | OutsideBound deriving Eq -- | Generic move operation -- Warning: moving To the (OutsideBound, Backward) bound of Document is impossible (offset -1!) -- @genMoveB u b d@: move in direction d until encountering boundary b or unit u. See 'genAtBoundaryB' for boundary explanation. genMoveB :: TextUnit -> (Direction, BoundarySide) -> Direction -> BufferM () genMoveB Document (Forward,InsideBound) Forward = moveTo =<< subtract 1 <$> sizeB genMoveB Document _ Forward = moveTo =<< sizeB genMoveB Document _ Backward = moveTo 0 -- impossible to go outside beginning of doc. genMoveB Character _ Forward = rightB genMoveB Character _ Backward = leftB genMoveB VLine _ Forward = do ofs <- lineMoveRel 1 when (ofs < 1) (maybeMoveB Line Forward) genMoveB VLine _ Backward = lineUp genMoveB unit (boundDir, boundSide) moveDir = doUntilB_ (genAtBoundaryB unit boundDir boundSide) (moveB Character moveDir) -- | Generic maybe move operation. -- As genMoveB, but don't move if we are at boundary already. genMaybeMoveB :: TextUnit -> (Direction, BoundarySide) -> Direction -> BufferM () -- optimized case for Document genMaybeMoveB Document boundSpec moveDir = genMoveB Document boundSpec moveDir -- optimized case for start/end of Line genMaybeMoveB Line (Backward, InsideBound) Backward = moveTo =<< solPointB =<< pointB genMaybeMoveB Line (Forward, OutsideBound) Forward = moveTo =<< eolPointB =<< pointB genMaybeMoveB unit (boundDir, boundSide) moveDir = untilB_ (genAtBoundaryB unit boundDir boundSide) (moveB Character moveDir) -- | Move to the next unit boundary moveB :: TextUnit -> Direction -> BufferM () moveB u d = genMoveB u (d, case d of Forward -> OutsideBound; Backward -> InsideBound) d -- | As 'moveB', unless the point is at a unit boundary -- So for example here moveToEol = maybeMoveB Line Forward; -- in that it will move to the end of current line and nowhere if we -- are already at the end of the current line. Similarly for moveToSol. maybeMoveB :: TextUnit -> Direction -> BufferM () maybeMoveB u d = genMaybeMoveB u (d, case d of Forward -> OutsideBound; Backward -> InsideBound) d transposeB :: TextUnit -> Direction -> BufferM () transposeB unit direction = do moveB unit (reverseDir direction) w0 <- pointB moveB unit direction w0' <- pointB moveB unit direction w1' <- pointB moveB unit (reverseDir direction) w1 <- pointB swapRegionsB (mkRegion w0 w0') (mkRegion w1 w1') moveTo w1' -- | Transforms the region given by 'TextUnit' in the 'Direction' with -- user-supplied function. transformB :: (YiString -> YiString) -> TextUnit -> Direction -> BufferM () transformB f unit direction = do p <- pointB moveB unit direction q <- pointB let r = mkRegion p q replaceRegionB r =<< f <$> readRegionB r -- | Delete between point and next unit boundary, return the deleted region. deleteB :: TextUnit -> Direction -> BufferM () deleteB unit dir = deleteRegionB =<< regionOfPartNonEmptyB unit dir regionWithTwoMovesB :: BufferM a -> BufferM b -> BufferM Region regionWithTwoMovesB move1 move2 = savingPointB $ mkRegion <$> (move1 >> pointB) <*> (move2 >> pointB) -- | Region of the whole textunit where the current point is. regionOfB :: TextUnit -> BufferM Region regionOfB unit = regionWithTwoMovesB (maybeMoveB unit Backward) (maybeMoveB unit Forward) -- An alternate definition would be the following, but it can return two units if the current point is between them. -- eg. "word1 ^ word2" would return both words. -- regionOfB unit = mkRegion -- <$> pointAfter (maybeMoveB unit Backward) -- <*> destinationOfMoveB (maybeMoveB unit Forward) -- | Non empty region of the whole textunit where the current point is. regionOfNonEmptyB :: TextUnit -> BufferM Region regionOfNonEmptyB unit = savingPointB $ mkRegion <$> (maybeMoveB unit Backward >> pointB) <*> (moveB unit Forward >> pointB) -- | Region between the point and the next boundary. -- The region is empty if the point is at the boundary. regionOfPartB :: TextUnit -> Direction -> BufferM Region regionOfPartB unit dir = mkRegion <$> pointB <*> destinationOfMoveB (maybeMoveB unit dir) -- | Non empty region between the point and the next boundary, -- In fact the region can be empty if we are at the end of file. regionOfPartNonEmptyB :: TextUnit -> Direction -> BufferM Region regionOfPartNonEmptyB unit dir = mkRegion <$> pointB <*> destinationOfMoveB (moveB unit dir) -- | Non empty region at given point and the next boundary, regionOfPartNonEmptyAtB :: TextUnit -> Direction -> Point -> BufferM Region regionOfPartNonEmptyAtB unit dir p = do oldP <- pointB moveTo p r <- regionOfPartNonEmptyB unit dir moveTo oldP return r readPrevUnitB :: TextUnit -> BufferM YiString readPrevUnitB unit = readRegionB =<< regionOfPartNonEmptyB unit Backward readUnitB :: TextUnit -> BufferM YiString readUnitB = readRegionB <=< regionOfB halfUnit :: Direction -> TextUnit -> TextUnit halfUnit dir (GenUnit enclosing boundary) = GenUnit enclosing (\d -> if d == dir then boundary d else return False) halfUnit _dir tu = tu deleteUnitB :: TextUnit -> Direction -> BufferM () deleteUnitB unit dir = deleteRegionB =<< regionOfPartNonEmptyB unit dir yi-core-0.19.4/src/Yi/Buffer/Undo.hs0000644000000000000000000001647707346545000015206 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | An implementation of restricted, linear undo, as described in: -- -- > T. Berlage, "A selective undo mechanism for graphical user interfaces -- > based on command objects", ACM Transactions on Computer-Human -- > Interaction 1(3), pp. 269-294, 1994. -- -- Implementation based on a proposal by sjw. -- -- From Berlage: -- -- > All buffer-mutating commands are stored (in abstract form) in an -- > Undo list. The most recent item in this list is the action that -- > will be undone next. When it is undone, it is removed from the Undo -- > list, and its inverse is added to the Redo list. The last command -- > put into the Redo list can be redone, and again prepended to the -- > Undo list. New commands are added to the Undo list without -- > affecting the Redo list. -- -- Now, the above assumes that commands can be _redone_ in a state other -- than that in which it was originally done. This is not the case in our -- text editor: a user may delete, for example, between an undo and a -- redo. Berlage addresses this in S2.3. A Yi example: -- -- > Delete some characters -- > Undo partially -- > Move prior in the file, and delete another _chunk_ -- > Redo some things == corruption. -- -- Berlage describes the /stable execution property/: -- -- > A command is always redone in the same state that it was originally -- > executed in, and is always undone in the state that was reached -- > after the original execution. -- -- > The only case where the linear undo model violates the stable -- > execution property is when _a new command is submitted while the -- > redo list is not empty_. The _restricted linear undo model_ ... -- > clears the redo list in this case. -- -- Also some discussion of this in: /The Text Editor Sam/, Rob Pike, pg 19. -- module Yi.Buffer.Undo ( emptyU , addChangeU , deleteInteractivePointsU , setSavedFilePointU , isAtSavedFilePointU , undoU , redoU , URList {- abstractly -} , Change(AtomicChange, InteractivePoint) ) where import Data.Binary (Binary (..)) import qualified Data.Sequence as S import GHC.Generics (Generic) import Yi.Buffer.Implementation data Change = SavedFilePoint | InteractivePoint | AtomicChange !Update -- !!! It's very important that the updates are forced, otherwise -- !!! we'll keep a full copy of the buffer state for each update -- !!! (thunk) put in the URList. deriving (Show, Generic) instance Binary Change -- | A URList consists of an undo and a redo list. data URList = URList !(S.Seq Change) !(S.Seq Change) deriving (Show, Generic) instance Binary URList -- | A new empty 'URList'. -- Notice we must have a saved file point as this is when we assume we are -- opening the file so it is currently the same as the one on disk emptyU :: URList emptyU = URList (S.singleton SavedFilePoint) S.empty -- | Add an action to the undo list. -- According to the restricted, linear undo model, if we add a command -- whilst the redo list is not empty, we will lose our redoable changes. addChangeU :: Change -> URList -> URList addChangeU InteractivePoint (URList us rs) = URList (addIP us) rs addChangeU u (URList us _) = URList (u S.<| us) S.empty deleteInteractivePointsU :: URList -> URList deleteInteractivePointsU (URList us rs) = URList (go us) rs where go (S.viewl -> InteractivePoint S.:< x) = go x go x = x -- | Add a saved file point so that we can tell that the buffer has not -- been modified since the previous saved file point. -- Notice that we must be sure to remove the previous saved file points -- since they are now worthless. setSavedFilePointU :: URList -> URList setSavedFilePointU (URList undos redos) = URList (SavedFilePoint S.<| cleanUndos) cleanRedos where cleanUndos = S.filter isNotSavedFilePoint undos cleanRedos = S.filter isNotSavedFilePoint redos isNotSavedFilePoint :: Change -> Bool isNotSavedFilePoint SavedFilePoint = False isNotSavedFilePoint _ = True -- | This undoes one interaction step. undoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, S.Seq Update)) undoU m = undoUntilInteractive m mempty . undoInteractive -- | This redoes one interaction step. redoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, S.Seq Update)) redoU = asRedo . undoU -- | Prepare undo by moving one interaction point from undoes to redoes. undoInteractive :: URList -> URList undoInteractive (URList us rs) = URList (remIP us) (addIP rs) -- | Remove an initial interactive point, if there is one remIP :: S.Seq Change -> S.Seq Change remIP xs = case S.viewl xs of InteractivePoint S.:< xs' -> xs' _ -> xs -- | Insert an initial interactive point, if there is none addIP :: S.Seq Change -> S.Seq Change addIP xs = case S.viewl xs of InteractivePoint S.:< _ -> xs _ -> InteractivePoint S.<| xs -- | Repeatedly undo actions, storing away the inverse operations in the -- redo list. undoUntilInteractive :: Mark -> S.Seq Update -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, S.Seq Update)) undoUntilInteractive pointMark xs ur@(URList cs rs) b = case S.viewl cs of S.EmptyL -> (b, (ur, xs)) SavedFilePoint S.:< (S.viewl -> S.EmptyL) -> (b, (ur, xs)) -- Why this special case? InteractivePoint S.:< _ -> (b, (ur, xs)) SavedFilePoint S.:< cs' -> undoUntilInteractive pointMark xs (URList cs' (SavedFilePoint S.<| rs)) b AtomicChange u S.:< cs' -> let ur' = URList cs' (AtomicChange (reverseUpdateI u) S.<| rs) b' = applyUpdateWithMoveI u b (b'', (ur'', xs')) = undoUntilInteractive pointMark xs ur' b' in (b'', (ur'', u S.<| xs')) where -- Apply a /valid/ update and also move point in buffer to update position applyUpdateWithMoveI :: Update -> BufferImpl syntax -> BufferImpl syntax applyUpdateWithMoveI upd = case updateDirection upd of Forward -> apply . move Backward -> move . apply where move = modifyMarkBI pointMark (\v -> v {markPoint = updatePoint u}) apply = applyUpdateI u -- | Run the undo-function @f@ on a swapped URList making it -- operate in a redo fashion instead of undo. asRedo :: (URList -> t -> (t, (URList, S.Seq Update))) -> URList -> t -> (t, (URList, S.Seq Update)) asRedo f ur x = let (y,(ur',rs)) = f (swapUndoRedo ur) x in (y,(swapUndoRedo ur',rs)) where swapUndoRedo :: URList -> URList swapUndoRedo (URList us rs) = URList rs us -- | undoIsAtSavedFilePoint. @True@ if the undo list is at a SavedFilePoint indicating -- that the buffer has not been modified since we last saved the file. -- Note: that an empty undo list does NOT mean that the buffer is not modified since -- the last save. Because we may have saved the file and then undone actions done before -- the save. isAtSavedFilePointU :: URList -> Bool isAtSavedFilePointU (URList us _) = isUnchanged us where isUnchanged cs = case S.viewl cs of S.EmptyL -> False SavedFilePoint S.:< _ -> True InteractivePoint S.:< cs' -> isUnchanged cs' _ -> False yi-core-0.19.4/src/Yi/Command.hs0000644000000000000000000001510107346545000014425 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Command -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Various high-level functions to further classify. module Yi.Command where import Control.Concurrent (MVar,newEmptyMVar,putMVar,takeMVar) import Control.Exception (SomeException) import Lens.Micro.Platform ((.=)) import Control.Monad (void) import Control.Monad.Base (liftBase) import Data.Binary (Binary) import Data.Default (Default) import qualified Data.Text as T (Text, init, filter, last, length, unpack) import Data.Typeable (Typeable) import System.Exit (ExitCode (..)) import Yi.Buffer (BufferId (MemBuffer), BufferRef, identA, setMode) import Yi.Core (startSubprocess) import Yi.Editor import Yi.Keymap (YiM, withUI) import Yi.MiniBuffer import qualified Yi.Mode.Compilation as Compilation (mode) import qualified Yi.Mode.Interactive as Interactive (mode,spawnProcess) import Yi.Monad (maybeM) import Yi.Process (runShellCommand, shellFileName) import qualified Yi.Rope as R (fromText) import Yi.Types (YiVariable) import Yi.UI.Common (reloadProject) import Yi.Utils (io) --------------------------- -- | Changing the buffer name quite useful if you have -- several the same. This also breaks the relation with the file. changeBufferNameE :: YiM () changeBufferNameE = withMinibufferFree "New buffer name:" strFun where strFun :: T.Text -> YiM () strFun = withCurrentBuffer . (.=) identA . MemBuffer ---------------------------- -- | shell-command with argument prompt shellCommandE :: YiM () shellCommandE = withMinibufferFree "Shell command:" shellCommandV ---------------------------- -- | shell-command with a known argument shellCommandV :: T.Text -> YiM () shellCommandV cmd = do (exitCode,cmdOut,cmdErr) <- liftBase . runShellCommand $ T.unpack cmd case exitCode of ExitSuccess -> if T.length (T.filter (== '\n') cmdOut) > 17 then withEditor . void $ -- see GitHub issue #477 newBufferE (MemBuffer "Shell Command Output") (R.fromText cmdOut) else printMsg $ case cmdOut of "" -> "(Shell command with no output)" -- Drop trailing newline from output xs -> if T.last xs == '\n' then T.init xs else xs ExitFailure _ -> printMsg cmdErr ---------------------------- -- Cabal-related commands newtype CabalBuffer = CabalBuffer {cabalBuffer :: Maybe BufferRef} deriving (Default, Typeable, Binary) instance YiVariable CabalBuffer ---------------------------- -- | cabal-configure cabalConfigureE :: CommandArguments -> YiM () cabalConfigureE = cabalRun "configure" configureExit configureExit :: Either SomeException ExitCode -> YiM () configureExit (Right ExitSuccess) = reloadProjectE "." configureExit _ = return () reloadProjectE :: String -> YiM () reloadProjectE s = withUI $ \ui -> reloadProject ui s -- | Run the given commands with args and pipe the output into the build buffer, -- which is shown in an other window. buildRun :: T.Text -> [T.Text] -> (Either SomeException ExitCode -> YiM x) -> YiM () buildRun cmd args onExit = withOtherWindow $ do b <- startSubprocess (T.unpack cmd) (T.unpack <$> args) onExit maybeM deleteBuffer =<< cabalBuffer <$> getEditorDyn putEditorDyn $ CabalBuffer $ Just b withCurrentBuffer $ setMode Compilation.mode return () -- | Run the given command with args in interactive mode. interactiveRun :: T.Text -> [T.Text] -> (Either SomeException ExitCode -> YiM x) -> YiM () interactiveRun cmd args onExit = withOtherWindow $ do bc <- liftBase $ newEmptyMVar b <- startSubprocess (T.unpack cmd) (T.unpack <$> args) $ \r -> do b <- liftBase $ takeMVar bc withGivenBuffer b $ setMode Compilation.mode onExit r maybeM deleteBuffer =<< cabalBuffer <$> getEditorDyn withCurrentBuffer $ setMode Interactive.mode liftBase $ putMVar bc b return () -- | Select 'buildRun' or 'interactiveRun' based on stack or cabal command name selectRunner :: T.Text -> T.Text -> [T.Text] -> (Either SomeException ExitCode -> YiM x) -> YiM () selectRunner command = if command `elem` ["eval","exec","ghci","repl","runghc","runhaskell","script"] then interactiveRun else buildRun makeBuild :: CommandArguments -> YiM () makeBuild (CommandArguments args) = buildRun "make" args (const $ return ()) cabalRun :: T.Text -> (Either SomeException ExitCode -> YiM x) -> CommandArguments -> YiM () cabalRun cmd onExit (CommandArguments args) = runner "cabal" (cmd:args) onExit where runner = selectRunner cmd makeRun :: (Either SomeException ExitCode -> YiM x) -> CommandArguments -> YiM () makeRun onExit (CommandArguments args) = buildRun "make" args onExit ----------------------- -- | cabal-build cabalBuildE :: CommandArguments -> YiM () cabalBuildE = cabalRun "build" (const $ return ()) makeBuildE :: CommandArguments -> YiM () makeBuildE = makeRun (const $ return ()) shell :: YiM BufferRef shell = do sh <- io shellFileName Interactive.spawnProcess sh ["-i"] -- use the -i option for interactive mode (assuming bash) -- | Search the source files in the project. searchSources :: String ::: RegexTag -> YiM () searchSources = grepFind (Doc "*.hs") -- | Perform a find+grep operation grepFind :: String ::: FilePatternTag -> String ::: RegexTag -> YiM () grepFind (Doc filePattern) (Doc searchedRegex) = withOtherWindow $ do void $ startSubprocess "find" [".", "-name", "_darcs", "-prune", "-o", "-name", filePattern, "-exec", "grep", "-Hnie", searchedRegex, "{}", ";"] (const $ return ()) withCurrentBuffer $ setMode Compilation.mode return () ----------------------- -- | stack-build stackCommandE :: T.Text -> CommandArguments -> YiM () stackCommandE cmd = stackRun cmd (const $ return ()) stackRun :: T.Text -> (Either SomeException ExitCode -> YiM x) -> CommandArguments -> YiM () stackRun cmd onExit (CommandArguments args) = runner "stack" (cmd:args) onExit where runner = selectRunner cmd yi-core-0.19.4/src/Yi/Command/0000755000000000000000000000000007346545000014073 5ustar0000000000000000yi-core-0.19.4/src/Yi/Command/Help.hs0000644000000000000000000000443007346545000015320 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Yi.Command.Help -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Help command support -- This module uses Yi.Eval.describeNamedAction to -- show whatever information about particular action is available -- from current evaluator (ghciEvaluator currently presents only type.) -- TODO: Would be nice to show excerpt from Haddock documentation in the future. -- -- If given no arguments, the help index is shown (using @getAllNamesInScope@). -- -- Please do not try to show descriptions for the whole index, -- as our interface to GHCi is too slow. module Yi.Command.Help(displayHelpFor) where import Data.Binary (Binary) import Data.Default (Default) import qualified Data.Text as T (Text, pack, unlines, unpack) import Data.Typeable (Typeable) import Yi.Buffer (BufferId (MemBuffer), BufferRef) import Yi.Editor import Yi.Eval (describeNamedAction, getAllNamesInScope) import Yi.Keymap (YiM) import Yi.Monad (maybeM) import qualified Yi.Rope as R (fromText) import Yi.Types (YiVariable) -- | Displays help for a given name, or help index, if no name is given displayHelpFor :: T.Text -> YiM () displayHelpFor name = helpFor name >>= displayHelpBuffer -- | Finds help text to display, given a command argument helpFor :: T.Text -> YiM T.Text helpFor "" = (T.unlines . map T.pack) <$> getAllNamesInScope helpFor name = T.pack <$> describeNamedAction (T.unpack name) -- * To make help buffer unique: -- | Dynamic YiVariable to store the help buffer reference. newtype HelpBuffer = HelpBuffer { helpBuffer :: Maybe BufferRef } deriving (Default, Typeable, Binary) instance YiVariable HelpBuffer -- | Display help buffer with a given text... displayHelpBuffer :: T.Text -> YiM () displayHelpBuffer text = withEditor $ withOtherWindow $ do maybeM deleteBuffer =<< helpBuffer <$> getEditorDyn b <- newBufferE (MemBuffer "*help*") $ R.fromText text putEditorDyn $ HelpBuffer $ Just b yi-core-0.19.4/src/Yi/Completion.hs0000644000000000000000000001401607346545000015164 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Completion -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Collection of functions for completion and matching. module Yi.Completion ( completeInList, completeInList' , completeInListCustomShow , commonPrefix , prefixMatch, infixUptoEndMatch , subsequenceMatch, subsequenceTextMatch , containsMatch', containsMatch, containsMatchCaseInsensitive , isCasePrefixOf ) where import Data.Function (on) import Data.List (find, nub) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T (Text, breakOn, isPrefixOf, length, null, tails, toCaseFold, splitAt) import Yi.Editor (EditorM, printMsg, printMsgs) import Yi.String (commonTPrefix', showT) import Yi.Utils (commonPrefix) ------------------------------------------- -- General completion -- | Like usual 'T.isPrefixOf' but user can specify case sensitivity. -- See 'T.toCaseFold' for exotic unicode gotchas. isCasePrefixOf :: Bool -- ^ Is case-sensitive? -> T.Text -> T.Text -> Bool isCasePrefixOf True = T.isPrefixOf isCasePrefixOf False = T.isPrefixOf `on` T.toCaseFold -- | Prefix matching function, for use with 'completeInList' prefixMatch :: T.Text -> T.Text -> Maybe T.Text prefixMatch prefix s = if prefix `T.isPrefixOf` s then Just s else Nothing -- | Text from the match up to the end, for use with 'completeInList' infixUptoEndMatch :: T.Text -> T.Text -> Maybe T.Text infixUptoEndMatch "" haystack = Just haystack infixUptoEndMatch needle haystack = case T.breakOn needle haystack of (_, t) -> if T.null t then Nothing else Just t -- | A simple fuzzy match algorithm. Example: "abc" matches "a1b2c" subsequenceMatch :: String -> String -> Bool subsequenceMatch needle haystack = go needle haystack where go (n:ns) (h:hs) | n == h = go ns hs go (n:ns) (h:hs) | n /= h = go (n:ns) hs go [] _ = True go _ [] = False go _ _ = False -- | A simple fuzzy match algorithm. Example: "abc" matches "a1b2c" subsequenceTextMatch :: Text -> Text -> Bool subsequenceTextMatch needle haystack | T.null needle = True | T.null haystack = False | n == h = subsequenceTextMatch ns hs | n /= h = subsequenceTextMatch needle hs | otherwise = False where n,ns,h,hs :: Text (n,ns) = T.splitAt 1 needle (h,hs) = T.splitAt 1 haystack -- | TODO: this is a terrible function, isn't this just -- case-insensitive infix? – Fūzetsu containsMatch' :: Bool -> T.Text -> T.Text -> Maybe T.Text containsMatch' caseSensitive pattern str = const str <$> find (pattern `tstPrefix`) (T.tails str) where tstPrefix = isCasePrefixOf caseSensitive containsMatch :: T.Text -> T.Text -> Maybe T.Text containsMatch = containsMatch' True containsMatchCaseInsensitive :: T.Text -> T.Text -> Maybe T.Text containsMatchCaseInsensitive = containsMatch' False -- | Complete a string given a user input string, a matching function -- and a list of possibilites. Matching function should return the -- part of the string that matches the user string. completeInList :: T.Text -- ^ Input to match on -> (T.Text -> Maybe T.Text) -- ^ matcher function -> [T.Text] -- ^ items to match against -> EditorM T.Text completeInList = completeInListCustomShow id -- | Same as 'completeInList', but maps @showFunction@ on possible -- matches when printing completeInListCustomShow :: (T.Text -> T.Text) -- ^ Show function -> T.Text -- ^ Input to match on -> (T.Text -> Maybe T.Text) -- ^ matcher function -> [T.Text] -- ^ items to match against -> EditorM T.Text completeInListCustomShow showFunction s match possibilities | null filtered = printMsg "No match" >> return s | prefix /= s = return prefix | isSingleton filtered = printMsg "Sole completion" >> return s | prefix `elem` filtered = printMsg ("Complete, but not unique: " <> showT filtered) >> return s | otherwise = printMsgs (map showFunction filtered) >> return (bestMatch filtered s) where prefix = commonTPrefix' filtered filtered = filterMatches match possibilities completeInList' :: T.Text -> (T.Text -> Maybe T.Text) -> [T.Text] -> EditorM T.Text completeInList' s match l = case filtered of [] -> printMsg "No match" >> return s [x] | s == x -> printMsg "Sole completion" >> return s | otherwise -> return x _ -> printMsgs filtered >> return (bestMatch filtered s) where filtered = filterMatches match l -- | This function attempts to provide a better tab completion result in -- cases where more than one file matches our prefix. Consider directory with -- following files: @["Main.hs", "Main.hi", "Main.o", "Test.py", "Foo.hs"]@. -- -- After inserting @Mai@ into the minibuffer and attempting to complete, the -- possible matches will be filtered in 'completeInList'' to -- @["Main.hs", "Main.hi", "Main.o"]@ however because of multiple matches, -- the buffer will not be updated to say @Main.@ but will instead stay at @Mai@. -- -- This is extremely tedious when trying to complete filenames in directories -- with many files so here we try to catch common prefixes of filtered files and -- if the result is longer than what we have, we use it instead. bestMatch :: [T.Text] -> T.Text -> T.Text bestMatch fs s = let p = commonTPrefix' fs in if T.length p > T.length s then p else s filterMatches :: Eq a => (b -> Maybe a) -> [b] -> [a] filterMatches match = nub . catMaybes . fmap match -- Not really necessary but a bit faster than @(length l) == 1@ isSingleton :: [a] -> Bool isSingleton [_] = True isSingleton _ = False yi-core-0.19.4/src/Yi/CompletionTree.hs0000644000000000000000000001557307346545000016015 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {- | Module : Yi.CompletionTree License : GPL-2 Maintainer : yi-devel@googlegroups.com Stability : experimental Portability : portable Little helper for completion interfaces. Intended to be imported qualified: >import qualified Yi.CompletionTree as CT -} module Yi.CompletionTree ( -- * CompletionTree type CompletionTree (CompletionTree), -- * Lists fromList, toList, -- * Modification complete, update, -- * Debugging pretty, -- ** Lens unCompletionTree ) where import Control.Arrow (first) import Data.Function (on) import Data.List (partition, maximumBy, intercalate) import qualified Data.Map.Strict as M import Data.Map.Strict (Map) import Data.Maybe (isJust, fromJust, listToMaybe, catMaybes) import qualified Data.ListLike as LL import Data.ListLike (ListLike) import Lens.Micro.Platform (over, Lens', _2, (.~), (&)) import Data.Binary (Binary) import Data.Semigroup (Semigroup) -- | A CompletionTree is a map of partial completions. -- -- Example: -- -- fromList ["put","putStr","putStrLn","print","abc"] -- -- Gives the following tree: -- -- / \ -- "p" "abc" -- / \ -- "ut" "rint" -- / \ -- "Str" "" -- / \ -- "Ln" "" -- -- (The empty strings are needed to denote the end of a word) -- (A CompletionTree is not limited to a binary tree) newtype CompletionTree a = CompletionTree {_unCompletionTree :: (Map a (CompletionTree a))} deriving (Semigroup, Monoid, Eq, Binary) unCompletionTree :: Lens' (CompletionTree a) (Map a (CompletionTree a)) unCompletionTree f ct = (\unCompletionTree' -> ct {_unCompletionTree = unCompletionTree'}) <$> f (_unCompletionTree ct) instance (Ord a, Show a, ListLike a i) => Show (CompletionTree a) where show ct = "fromList " ++ show (toList ct) -- | This function converts a list of completable elements to a CompletionTree -- It finds elements that share a common prefix and groups them. -- -- prop> fromList . toList = id fromList :: (Ord a, ListLike a i, Eq i) => [a] -> CompletionTree a fromList [] = mempty fromList (x:xs) | x == mempty = over unCompletionTree (M.insert mempty mempty) (fromList xs) | otherwise = case maximumBy' (compare `on` childrenIn xs) (tail $ LL.inits x) of Nothing -> over unCompletionTree (M.insert x mempty) (fromList xs) Just parent -> case first (x:) $ partition (parent `LL.isPrefixOf`) xs of ([_],rest) -> over unCompletionTree (M.insert parent mempty) $ fromList rest (hasParent, rest) -> over unCompletionTree (M.insert parent (fromList $ map (fromJust . LL.stripPrefix parent) hasParent)) $ fromList rest -- A parent is the prefix and the children are the items with the parent as prefix where childrenIn :: (ListLike a i, Eq i) => [a] -> a -> Int childrenIn list parent = length $ filter (parent `LL.isPrefixOf`) list -- | The largest element of a non-empty structure with respect to the -- given comparison function, Nothing if there are multiple 'largest' elements. maximumBy' :: Eq a => (a -> a -> Ordering) -> [a] -> Maybe a maximumBy' cmp l | atleast 2 (== max') l = Nothing | otherwise = Just max' where max' = maximumBy cmp l -- This short-circuits if the condition is met n times before the end of the list. atleast :: Int -> (a -> Bool) -> [a] -> Bool atleast 0 _ _ = True atleast _ _ [] = False atleast n cmp' (x:xs) | cmp' x = atleast (n - 1) cmp' xs | otherwise = atleast n cmp' xs -- | Complete as much as possible without guessing. -- -- Examples: -- -- >>> complete $ fromList ["put","putStrLn","putStr"] -- ("put", fromList ["","Str","StrLn"]) -- -- >>> complete $ fromList ["put","putStr","putStrLn","abc"] -- ("", fromList ["put","putStr","putStrLn","abc"]) complete :: (Eq i, Ord a, ListLike a i) => CompletionTree a -> (a, CompletionTree a) complete (CompletionTree ct) | M.size ct == 1 = if snd (M.elemAt 0 ct) == mempty then M.elemAt 0 ct & _2 .~ fromList [mempty] else M.elemAt 0 ct | otherwise = (mempty,CompletionTree ct) -- | Update the CompletionTree with new information. -- An empty list means that there is no completion left. -- A [mempty] means that the end of a word is reached. -- -- Examples: -- -- >>> update (fromList ["put","putStr"]) "p" -- fromList ["ut","utStr"] -- -- >>> update (fromList ["put","putStr"]) "put" -- fromList ["","Str"] -- -- >>> update (fromList ["put","putStr"]) "putS" -- fromList ["tr"] -- -- >>> update (fromList ["put"]) "find" -- fromList [] -- -- >>> update (fromList ["put"]) "put" -- fromList [""] update :: (Ord a, ListLike a i, Eq i) => CompletionTree a -> a -> CompletionTree a update (CompletionTree ct) p -- p is empty, this case just doesn't make sense: | mempty == p = error "Can't update a CompletionTree with a mempty" -- p is a key in the map ct that doesn't have children: -- (This means the end of a word is reached) | isJust one && mempty == fromJust one = CompletionTree $ M.singleton mempty mempty -- p is a key in the map ct with children: | isJust one = fromJust one -- a substring of p is a key in ct: | isJust remaining = uncurry update $ fromJust remaining -- p is a substring of a key in ct: | otherwise = CompletionTree $ M.mapKeys fromJust $ M.filterWithKey (const . isJust) $ M.mapKeys (LL.stripPrefix p) ct where one = M.lookup p ct remaining = listToMaybe . catMaybes $ map (\p' -> (,fromJust $ LL.stripPrefix p' p) <$> M.lookup p' ct) (tail $ LL.inits p) -- | Converts a CompletionTree to a list of completions. -- -- prop> toList . fromList = sort . nub -- -- Examples: -- -- >>> toList mempty -- [] -- -- >>> toList (fromList ["a"]) -- ["a"] -- -- >>> toList (fromList ["a","a","a"]) -- ["a"] -- -- >>> toList (fromList ["z","x","y"]) -- ["x","y","z"] toList :: (Ord a, ListLike a i) => CompletionTree a -> [a] toList ct | mempty == ct = [] | otherwise = toList' ct where toList' :: (Ord a, ListLike a i) => CompletionTree a -> [a] toList' (CompletionTree ct') | M.null ct' = [mempty] | otherwise = concat $ M.elems $ M.mapWithKey (\k v -> map (k `LL.append`) $ toList' v) ct' -- TODO: make this function display a tree and rename to showTree -- | For debugging purposes. -- -- Example: -- -- >>> putStrLn $ pretty $ fromList ["put", "putStr", "putStrLn"] -- ["put"[""|"Str"[""|"Ln"]]] pretty :: Show a => CompletionTree a -> String pretty (CompletionTree ct) | M.null ct = "" | otherwise = "[" ++ intercalate "|" (M.elems (M.mapWithKey (\k v -> shows k (pretty v)) ct)) ++ "]" yi-core-0.19.4/src/Yi/Config.hs0000644000000000000000000000175607346545000014267 0ustar0000000000000000{-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Config -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Module exposing common user settings. Users most likely want to be starting -- with "Yi.Config.Default". module Yi.Config ( Config(..), UIConfig(..), UIBoot, CursorStyle(..) , module Yi.Config.Lens , configStyle, configFundamentalMode, configTopLevelKeymap ) where import Data.Prototype (extractValue) import Yi.Config.Lens import Yi.Style (UIStyle) import Yi.Types (AnyMode, Config (..), CursorStyle (..), Keymap, UIBoot, UIConfig (..), extractTopKeymap) configStyle :: UIConfig -> UIStyle configStyle = extractValue . configTheme configFundamentalMode :: Config -> AnyMode configFundamentalMode = last . modeTable configTopLevelKeymap :: Config -> Keymap configTopLevelKeymap = extractTopKeymap . defaultKm yi-core-0.19.4/src/Yi/Config/0000755000000000000000000000000007346545000013722 5ustar0000000000000000yi-core-0.19.4/src/Yi/Config/Default.hs0000644000000000000000000001227307346545000015647 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Yi.Config.Default (defaultConfig) where import Lens.Micro.Platform ((.~)) import qualified Data.HashMap.Strict as HM import Data.Monoid import Paths_yi_core import System.FilePath import Yi.Buffer import Yi.Command (cabalBuildE, cabalConfigureE, grepFind, makeBuild, reloadProjectE, searchSources, shell) import Yi.Config import Yi.Core (errorEditor, quitEditor) import Yi.Editor import Yi.Eval (publishedActions) import Yi.File import qualified Yi.Interact as I import Yi.Keymap import Yi.Keymap.Keys import Yi.Layout import Yi.Mode.Common (fundamentalMode) import qualified Yi.Rope as R import Yi.Search import Yi.Style.Library import Yi.Utils import Yi.Types () -- | List of published Actions -- THIS MUST BE OF THE FORM: -- ("symbol", box symbol") -- ... so we can hope getting rid of this someday. -- Failing to conform to this rule exposes the code to instant deletion. -- -- TODO: String → Text/YiString defaultPublishedActions :: HM.HashMap String Action defaultPublishedActions = HM.fromList [ ("atBoundaryB" , box atBoundaryB) , ("cabalBuildE" , box cabalBuildE) , ("cabalConfigureE" , box cabalConfigureE) , ("closeBufferE" , box closeBufferE) , ("deleteB" , box deleteB) , ("deleteBlankLinesB" , box deleteBlankLinesB) , ("getSelectRegionB" , box getSelectRegionB) , ("grepFind" , box grepFind) , ("insertB" , box insertB) , ("leftB" , box leftB) , ("linePrefixSelectionB" , box linePrefixSelectionB) , ("lineStreamB" , box lineStreamB) -- , ("mkRegion" , box mkRegion) -- can't make 'instance Promptable Region' , ("makeBuild" , box makeBuild) , ("moveB" , box moveB) , ("numberOfB" , box numberOfB) , ("pointB" , box pointB) , ("regionOfB" , box regionOfB) , ("regionOfPartB" , box regionOfPartB) , ("regionOfPartNonEmptyB" , box regionOfPartNonEmptyB) , ("reloadProjectE" , box reloadProjectE) , ("replaceString" , box replaceString) , ("revertE" , box revertE) , ("shell" , box shell) , ("searchSources" , box searchSources) , ("setAnyMode" , box setAnyMode) , ("sortLines" , box sortLines) , ("unLineCommentSelectionB", box unLineCommentSelectionB) , ("writeB" , box writeB) ] where box :: (Show x, YiAction a x) => a -> Action box = makeAction defaultConfig :: Config defaultConfig = publishedActions .~ defaultPublishedActions $ Config { startFrontEnd = error "panic: no frontend compiled in! (configure with -fvty or another frontend.)" , configUI = UIConfig { configFontSize = Just 10 , configFontName = Nothing , configScrollWheelAmount = 4 , configScrollStyle = Nothing , configCursorStyle = FatWhenFocusedAndInserting , configLineWrap = True , configLeftSideScrollBar = True , configAutoHideScrollBar = False , configAutoHideTabBar = True , configWindowFill = ' ' , configTheme = defaultTheme , configLineNumbers = False } , defaultKm = modelessKeymapSet nilKeymap , startActions = mempty , initialActions = mempty , modeTable = [AnyMode fundamentalMode] , debugMode = False , configKillringAccumulate = False , configCheckExternalChangesObsessively = True , configRegionStyle = Exclusive , configInputPreprocess = I.idAutomaton , bufferUpdateHandler = mempty , layoutManagers = [hPairNStack 1, vPairNStack 1, tall, wide] , configVars = mempty } nilKeymap :: Keymap nilKeymap = choice [ char 'q' ?>>! quitEditor, char 'h' ?>>! configHelp ] <|| (anyEvent >>! errorEditor "Keymap not defined, 'q' to quit, 'h' for help.") where configHelp :: YiM () configHelp = do dataDir <- io getDataDir let x y = R.fromString (x y) welcomeText = R.unlines [ "This instance of Yi is not configured." , "" , "To get a standard reasonable keymap, you can run yi with" , "either --as=cua, --as=vim or --as=emacs." , "" , "You should however create your own ~/.config/yi/yi.hs file." , "As a starting point it's recommended to use one of the configs" , "from " <> (dataDir "example-configs/") , "" ] withEditor_ $ newBufferE (MemBuffer "configuration help") welcomeText yi-core-0.19.4/src/Yi/Config/Lens.hs0000644000000000000000000000143107346545000015156 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Config.Lens -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Lenses for types exported in Yi.Config. This module serves as a -- convenience module, for easy re-exporting. module Yi.Config.Lens where import Lens.Micro.Platform (Lens) import Data.Default (Default (def)) import Data.DynamicState (_dyn) import Yi.Types (Config (..), UIConfig (..), YiConfigVariable) import Yi.Utils (makeLensesWithSuffix) makeLensesWithSuffix "A" ''Config makeLensesWithSuffix "A" ''UIConfig configVariable :: YiConfigVariable a => Lens Config Config a a configVariable = configVarsA . _dyn def yi-core-0.19.4/src/Yi/Config/Misc.hs0000644000000000000000000000011207346545000015143 0ustar0000000000000000module Yi.Config.Misc where data ScrollStyle = SnapToCenter | SingleLine yi-core-0.19.4/src/Yi/Config/Simple.hs0000644000000000000000000002755507346545000015525 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Config.Simple -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- A simplified configuration interface for Yi. -- -- This module provides a simple configuration API, allowing users to -- start with an initial configuration and imperatively (monadically) -- modify it. Some common actions (keybindings, selecting modes, -- choosing the frontend) have been given special commands -- ('globalBindKeys', 'setFrontendPreferences', 'addMode', and so on). -- -- A simple configuration might look like the following: -- -- @ -- import Yi.Config.Simple -- import Yi.Boot -- import qualified Yi.Mode.Haskell as Haskell -- -- note: don't import "Yi", or else there will be name clashes -- -- main = 'configMain' 'defaultEmacsConfig' $ do -- 'fontSize' '%=' 'Just' 10 -- 'modeBindKeys' Haskell.cleverMode ('metaCh' \'q\' '?>>!' 'reload') -- 'globalBindKeys' ('metaCh' \'r\' '?>>!' 'reload') -- @ -- -- A lot of the fields here are specified with the 'Field' type. To write -- a field, use ('%='). To read, use 'get'. For modification, use -- ('modify'). For example, the functions @foo@ and @bar@ are equivalent: -- -- @ -- foo = 'modify' 'layoutManagers' 'reverse' -- bar = do -- lms <- 'get' 'layoutManagers' -- 'layoutManagers' '%=' 'reverse' lms -- @ module Yi.Config.Simple ( -- * The main interface ConfigM, Field, -- * Modes, commands, and keybindings globalBindKeys, modeBindKeys, modeBindKeysByName, addMode, modifyMode, modifyModeByName, -- * Evaluation of commands evaluator, #ifdef HINT ghciEvaluator, #endif publishedActionsEvaluator, publishAction, publishedActions, -- * Appearance fontName, fontSize, scrollWheelAmount, scrollStyle, ScrollStyle(..), cursorStyle, CursorStyle(..), Side(..), scrollBarSide, autoHideScrollBar, autoHideTabBar, lineWrap, windowFill, theme, lineNumbers, -- ** Layout layoutManagers, -- * Debugging debug, -- * Startup hooks runOnStartup, runAfterStartup, -- * Advanced -- $advanced startActions, initialActions, defaultKm, inputPreprocess, modes, regionStyle, killringAccumulate, bufferUpdateHandler, -- * Module exports -- we can't just export 'module Yi', because then we would get -- clashes with Yi.Config module Yi.Buffer, module Yi.Core, module Yi.Dired, module Yi.Editor, module Yi.File, module Yi.Config, module Yi.Config.Default, module Yi.Keymap, module Yi.Keymap.Keys, module Yi.Layout, module Yi.Search, module Yi.Style, module Yi.Style.Library, module Yi.Misc, ) where import Lens.Micro.Platform (Lens', (%=), (%~), use, lens) import qualified Data.Text as T import qualified Data.Sequence as S import Text.Printf(printf) import Yi.Buffer hiding (modifyMode) import Yi.Config.Default import Yi.Config.Misc import Yi.Config.Simple.Types import Yi.Core import Yi.Dired import Yi.Editor import Yi.Eval import Yi.File import Yi.Keymap import Yi.Keymap.Keys import Yi.Layout import Yi.Misc import Yi.Search import Yi.Style import Yi.Style.Library import Yi.Utils -- we do explicit imports because we reuse a lot of the names import Yi.Config(Config, UIConfig, startFrontEndA, configUIA, startActionsA, initialActionsA, defaultKmA, configInputPreprocessA, modeTableA, debugModeA, configRegionStyleA, configKillringAccumulateA, bufferUpdateHandlerA, configFontNameA, configFontSizeA, configScrollWheelAmountA, configScrollStyleA, configCursorStyleA, CursorStyle(..), configLeftSideScrollBarA, configAutoHideScrollBarA, configAutoHideTabBarA, configLineWrapA, configWindowFillA, configThemeA, layoutManagersA, configVarsA, configLineNumbersA ) --------------- Main interface -- newtype ConfigM a (imported) ------------------------- Modes, commands, and keybindings -- | Adds the given key bindings to the `global keymap'. The bindings -- will override existing bindings in the case of a clash. globalBindKeys :: Keymap -> ConfigM () globalBindKeys a = (defaultKmA . topKeymapA) %= (||> a) -- | @modeBindKeys mode keys@ adds the keybindings in @keys@ to all -- modes with the same name as @mode@. -- -- As with 'modifyMode', a mode by the given name must already be -- registered, or the function will have no effect, and issue a -- command-line warning. modeBindKeys :: Mode syntax -> Keymap -> ConfigM () modeBindKeys mode keys = ensureModeRegistered "modeBindKeys" (modeName mode) boundKeys where boundKeys = modeBindKeysByName (modeName mode) keys -- | @modeBindKeysByName name keys@ adds the keybindings in @keys@ to -- all modes with name @name@ (if it is registered). Consider using -- 'modeBindKeys' instead. modeBindKeysByName :: T.Text -> Keymap -> ConfigM () modeBindKeysByName name k = ensureModeRegistered "modeBindKeysByName" name modMode where f :: (KeymapSet -> KeymapSet) -> KeymapSet -> KeymapSet f mkm km = topKeymapA %~ (||> k) $ mkm km modMode = modifyModeByName name (modeKeymapA %~ f) -- | Register the given mode. It will be preferred over any modes -- already defined. addMode :: Mode syntax -> ConfigM () addMode m = modeTableA %= (AnyMode m :) -- | @modifyMode mode f@ modifies all modes with the same name as -- @mode@, using the function @f@. -- -- Note that the @mode@ argument is only used by its 'modeName'. In -- particular, a mode by the given name must already be registered, or -- this function will have no effect, and issue a command-line -- warning. -- -- @'modifyMode' mode f = 'modifyModeByName' ('modeName' mode) f@ modifyMode :: Mode syntax -> (forall syntax'. Mode syntax' -> Mode syntax') -> ConfigM () modifyMode mode f = ensureModeRegistered "modifyMode" (modeName mode) modMode where modMode = modifyModeByName (modeName mode) f -- | @modifyModeByName name f@ modifies the mode with name @name@ -- using the function @f@. Consider using 'modifyMode' instead. modifyModeByName :: T.Text -> (forall syntax. Mode syntax -> Mode syntax) -> ConfigM () modifyModeByName name f = ensureModeRegistered "modifyModeByName" name $ modeTableA %= fmap (onMode g) where g :: forall syntax. Mode syntax -> Mode syntax g m | modeName m == name = f m | otherwise = m -- helper functions warn :: String -> String -> ConfigM () warn caller msg = io $ putStrLn $ printf "Warning: %s: %s" caller msg -- the putStrLn shouldn't be necessary, but it doesn't print anything -- if it's not there... isModeRegistered :: T.Text -> ConfigM Bool isModeRegistered name = any (\(AnyMode mode) -> modeName mode == name) <$> use modeTableA -- ensure the given mode is registered, and if it is, then run the given action. ensureModeRegistered :: String -> T.Text -> ConfigM () -> ConfigM () ensureModeRegistered caller name m = do isRegistered <- isModeRegistered name if isRegistered then m else warn caller (printf "mode \"%s\" is not registered." (T.unpack name)) --------------------- Appearance -- | 'Just' the font name, or 'Nothing' for default. fontName :: Field (Maybe String) fontName = configUIA . configFontNameA -- | 'Just' the font size, or 'Nothing' for default. fontSize :: Field (Maybe Int) fontSize = configUIA . configFontSizeA -- | Amount to move the buffer when using the scroll wheel. scrollWheelAmount :: Field Int scrollWheelAmount = configUIA . configScrollWheelAmountA -- | 'Just' the scroll style, or 'Nothing' for default. scrollStyle :: Field (Maybe ScrollStyle) scrollStyle = configUIA . configScrollStyleA -- | See 'CursorStyle' for documentation. cursorStyle :: Field CursorStyle cursorStyle = configUIA . configCursorStyleA data Side = LeftSide | RightSide -- | Which side to display the scroll bar on. scrollBarSide :: Field Side scrollBarSide = configUIA . configLeftSideScrollBarA . fromBool where fromBool :: Lens' Bool Side fromBool = lens (\b -> if b then LeftSide else RightSide) (\_ s -> case s of { LeftSide -> True; RightSide -> False }) -- | Should the scroll bar autohide? autoHideScrollBar :: Field Bool autoHideScrollBar = configUIA . configAutoHideScrollBarA -- | Should the tab bar autohide? autoHideTabBar :: Field Bool autoHideTabBar = configUIA . configAutoHideTabBarA -- | Should lines be wrapped? lineWrap :: Field Bool lineWrap = configUIA . configLineWrapA -- | The character with which to fill empty window space. Usually -- \'~\' for vi-like editors, \' \' for everything else. windowFill :: Field Char windowFill = configUIA . configWindowFillA -- | UI colour theme. theme :: Field Theme theme = configUIA . configThemeA -- | Line numbers. lineNumbers :: Field Bool lineNumbers = configUIA . configLineNumbersA ---------- Layout -- | List of registered layout managers. When cycling through layouts, -- this list will be consulted. layoutManagers :: Field [AnyLayoutManager] layoutManagers = layoutManagersA ------------------------ Debugging -- | Produce a .yi.dbg file with debugging information? debug :: Field Bool debug = debugModeA ----------- Startup hooks -- | Run when the editor is started (this is run after all actions -- which have already been registered) runOnStartup :: Action -> ConfigM () runOnStartup action = runManyOnStartup [action] -- | List version of 'runOnStartup'. runManyOnStartup :: [Action] -> ConfigM () runManyOnStartup actions = startActions %= (++ actions) -- | Run after the startup actions have completed, or on reload (this -- is run after all actions which have already been registered) runAfterStartup :: Action -> ConfigM () runAfterStartup action = runManyAfterStartup [action] -- | List version of 'runAfterStartup'. runManyAfterStartup :: [Action] -> ConfigM () runManyAfterStartup actions = initialActions %= (++ actions) ------------------------ Advanced {- $advanced These fields are here for completeness -- that is, to expose all the functionality of the "Yi.Config" module. However, most users probably need not use these fields, typically because they provide advanced functionality, or because a simpler interface for the common case is available above. -} -- | Actions to run when the editor is started. Consider using -- 'runOnStartup' or 'runManyOnStartup' instead. startActions :: Field [Action] startActions = startActionsA -- | Actions to run after startup or reload. Consider using -- 'runAfterStartup' or 'runManyAfterStartup' instead. initialActions :: Field [Action] initialActions = initialActionsA -- | Default keymap to use. defaultKm :: Field KeymapSet defaultKm = defaultKmA -- | ? inputPreprocess :: Field (P Event Event) inputPreprocess = configInputPreprocessA -- | List of modes by order of preference. Consider using 'addMode', -- 'modeBindKeys', or 'modifyMode' instead. modes :: Field [AnyMode] modes = modeTableA -- | Set to 'Exclusive' for an emacs-like behaviour. Consider starting -- with 'defaultEmacsConfig', 'defaultVimConfig', or -- 'defaultCuaConfig' to instead. regionStyle :: Field RegionStyle regionStyle = configRegionStyleA -- | Set to 'True' for an emacs-like behaviour, where all deleted text -- is accumulated in a killring. Consider starting with -- 'defaultEmacsConfig', 'defaultVimConfig', or 'defaultCuaConfig' -- instead. killringAccumulate :: Field Bool killringAccumulate = configKillringAccumulateA -- | ? bufferUpdateHandler :: Field (S.Seq (S.Seq Update -> BufferM ())) bufferUpdateHandler = bufferUpdateHandlerA yi-core-0.19.4/src/Yi/Config/Simple/0000755000000000000000000000000007346545000015153 5ustar0000000000000000yi-core-0.19.4/src/Yi/Config/Simple/Types.hs0000644000000000000000000000257707346545000016626 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} -- | exports from "Yi.Config.Simple" which are useful to \"core yi\" rather than just config files. module Yi.Config.Simple.Types where import Lens.Micro.Platform (Lens') import Control.Monad.Base (MonadBase) import Control.Monad.State (MonadState, StateT) import Yi.Config (Config, configVariable) import Yi.Types (YiConfigVariable) -- | The configuration monad. Run it with 'configMain'. newtype ConfigM a = ConfigM { runConfigM :: StateT Config IO a } deriving (Monad, Functor, Applicative, MonadState Config, MonadBase IO) -- | Fields that can be modified with all lens machinery. type Field a = Lens' Config a {- | Accessor for any 'YiConfigVariable', to be used by modules defining 'YiConfigVariable's. Such modules should provide a custom-named field. For instance, take the following hypothetical 'YiConfigVariable': @newtype UserName = UserName { unUserName :: String } deriving(Typeable, Binary, Default) instance YiConfigVariable UserName $(nameDeriveAccessors ''UserName (\n -> Just (n ++ \"A\"))) userName :: 'Field' 'String' userName = unUserNameA '.' 'customVariable'@ Here, the hypothetical library would provide the field @userName@ to be used in preference to @customVariable@. -} customVariable :: YiConfigVariable a => Field a customVariable = configVariable yi-core-0.19.4/src/Yi/Core.hs0000644000000000000000000005203607346545000013747 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Core -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- The core actions of Yi. This module is the link between the editor -- and the UI. Key bindings, and libraries should manipulate Yi -- through the interface defined here. module Yi.Core ( -- * Construction and destruction startEditor , quitEditor -- :: YiM () , quitEditorWithExitCode -- :: ExitCode -> YiM () -- * User interaction , refreshEditor -- :: YiM () , suspendEditor -- :: YiM () , userForceRefresh -- * Global editor actions , errorEditor -- :: String -> YiM () , closeWindow -- :: YiM () , closeWindowEmacs -- * Interacting with external commands , runProcessWithInput -- :: String -> String -> YiM String , startSubprocess -- :: FilePath -> [String] -> YiM () , sendToProcess -- * Misc , runAction , withSyntax , focusAllSyntax , onYiVar ) where import Prelude hiding (elem, mapM_, or) import Control.Concurrent (forkOS, modifyMVar, modifyMVar_ ,newMVar, readMVar, threadDelay) import Control.Exc (ignoringException) import Control.Exception (SomeException, handle) import Lens.Micro.Platform (mapped, use, view, (%=), (%~), (&), (.=), (.~), (^.)) import Control.Monad (forever, void, when) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Except () import Control.Monad.Reader (MonadReader (ask), ReaderT (runReaderT), asks) import qualified Data.DelayList as DelayList (decrease, insert) import Data.Foldable (elem, find, forM_, mapM_, or, toList) import Data.List (partition) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.PointedList.Circular as PL (PointedList (_focus), length) import Data.List.Split (splitOn) import qualified Data.Map as M (assocs, delete, empty, fromList, insert, member) import Data.Maybe (fromMaybe, isNothing) import Data.Monoid (First (First, getFirst), (<>), mempty) import qualified Data.Text as T (Text, pack, unwords) import Data.Time (getCurrentTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Traversable (forM) import GHC.Conc (labelThread) import System.Directory (doesFileExist) import System.Exit (ExitCode (ExitSuccess)) import System.IO (Handle, hPutStr, hWaitForInput) import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Process (ProcessHandle, getProcessExitCode, readProcessWithExitCode, terminateProcess) import Yi.Buffer import Yi.Config import Yi.Debug (logPutStrLn) import Yi.Editor import Yi.Keymap import Yi.Keymap.Keys import Yi.KillRing (krEndCmd) import Yi.Monad (gets, uses) import Yi.PersistentState (loadPersistentState, savePersistentState) import Yi.Process import qualified Yi.Rope as R (YiString, fromString, readFile) import Yi.String (chomp, showT) import Yi.Style (errorStyle, strongHintStyle) import qualified Yi.UI.Common as UI (UI (end, layout, main, refresh, suspend, userForceRefresh)) import Yi.Utils (io) import Yi.Window (bufkey, dummyWindow, isMini, winRegion, wkey) -- | Make an action suitable for an interactive run. -- UI will be refreshed. interactive :: IsRefreshNeeded -> [Action] -> YiM () interactive isRefreshNeeded action = do evs <- withEditor $ use pendingEventsA logPutStrLn $ ">>> interactively" <> showEvs evs withEditor $ buffersA %= (fmap $ undosA %~ addChangeU InteractivePoint) mapM_ runAction action withEditor $ killringA %= krEndCmd when (isRefreshNeeded == MustRefresh) refreshEditor logPutStrLn "<<<" return () -- --------------------------------------------------------------------- -- | Start up the editor, setting any state with the user preferences -- and file names passed in, and turning on the UI -- startEditor :: Config -> Maybe Editor -> IO () startEditor cfg st = do let uiStart = startFrontEnd cfg logPutStrLn "Starting Core" -- Use an empty state unless resuming from an earlier session and -- one is already available let editor = fromMaybe emptyEditor st -- here to add load history etc? -- Setting up the 1st window is a bit tricky because most -- functions assume there exists a "current window" newSt <- newMVar $ YiVar editor 1 M.empty (ui, runYi) <- mdo let handler (exception :: SomeException) = runYi $ errorEditor (showT exception) >> refreshEditor inF [] = return () inF (e:es) = handle handler $ runYi $ dispatch (e :| es) outF refreshNeeded acts = handle handler $ runYi $ interactive refreshNeeded acts runYi f = runReaderT (runYiM f) yi yi = Yi ui inF outF cfg newSt ui <- uiStart cfg inF (outF MustRefresh) editor return (ui, runYi) runYi loadPersistentState runYi $ do if isNothing st -- process options if booting for the first time then postActions NoNeedToRefresh $ startActions cfg -- otherwise: recover the mode of buffers else withEditor $ buffersA.mapped %= recoverMode (modeTable cfg) postActions NoNeedToRefresh $ initialActions cfg ++ [makeAction showErrors] runYi refreshEditor UI.main ui -- transfer control to UI recoverMode :: [AnyMode] -> FBuffer -> FBuffer recoverMode tbl buffer = case fromMaybe (AnyMode emptyMode) (find (\(AnyMode m) -> modeName m == oldName) tbl) of AnyMode m -> setMode0 m buffer where oldName = case buffer of FBuffer {bmode = m} -> modeName m postActions :: IsRefreshNeeded -> [Action] -> YiM () postActions refreshNeeded actions = do yi <- ask; liftBase $ yiOutput yi refreshNeeded actions -- | Display the errors buffer in a new split window if it exists. showErrors :: YiM () showErrors = withEditor $ do bs <- gets $ doesBufferNameExist "*errors*" when bs $ do splitE switchToBufferWithNameE "*errors*" -- | Process events by advancing the current keymap automaton and -- executing the generated actions. dispatch :: NonEmpty Event -> YiM () dispatch (ev :| evs) = do yi <- ask (userActions, _p') <- withCurrentBuffer $ do keymap <- gets (withMode0 modeKeymap) p0 <- use keymapProcessA let km = extractTopKeymap $ keymap $ defaultKm $ yiConfig yi let freshP = Chain (configInputPreprocess $ yiConfig yi) (mkAutomaton km) p = case computeState p0 of Dead -> freshP _ -> p0 (actions, p') = processOneEvent p ev state = computeState p' ambiguous = case state of Ambiguous _ -> True _ -> False keymapProcessA .= (if ambiguous then freshP else p') let actions0 = case state of Dead -> [EditorA $ do evs' <- use pendingEventsA printMsg ("Unrecognized input: " <> showEvs (evs' ++ [ev]))] _ -> actions actions1 = [ EditorA (printMsg "Keymap was in an ambiguous state! Resetting it.") | ambiguous] return (actions0 ++ actions1, p') let decay, pendingFeedback :: EditorM () decay = statusLinesA %= DelayList.decrease 1 pendingFeedback = do pendingEventsA %= (++ [ev]) if null userActions then printMsg . showEvs =<< use pendingEventsA else pendingEventsA .= [] allActions = [makeAction decay] ++ userActions ++ [makeAction pendingFeedback] case evs of [] -> postActions MustRefresh allActions (e:es) -> postActions NoNeedToRefresh allActions >> dispatch (e :| es) showEvs :: [Event] -> T.Text showEvs = T.unwords . fmap (T.pack . prettyEvent) -- --------------------------------------------------------------------- -- Meta operations -- | Quit. quitEditor :: YiM () quitEditor = quitEditorWithExitCode ExitSuccess -- | Quit with an exit code. (This is used to implement vim's :cq command) quitEditorWithExitCode :: ExitCode -> YiM () quitEditorWithExitCode exitCode = do savePersistentState onYiVar $ terminateSubprocesses (const True) withUI (`UI.end` (Just exitCode)) -- | Update (visible) buffers if they have changed on disk. -- FIXME: since we do IO here we must catch exceptions! checkFileChanges :: Editor -> IO Editor checkFileChanges e0 = do now <- getCurrentTime -- Find out if any file was modified "behind our back" by -- other processes. newBuffers <- forM (buffers e0) $ \b -> let nothing = return (b, Nothing) in if bkey b `elem` visibleBuffers then case b ^. identA of FileBuffer fname -> do fe <- doesFileExist fname if not fe then nothing else do modTime <- fileModTime fname if b ^. lastSyncTimeA < modTime then if isUnchangedBuffer b then R.readFile fname >>= return . \case Left m -> (runDummy b (readOnlyA .= True), Just $ msg3 m) Right newContents -> (runDummy b (revertB newContents now), Just msg1) else return (b, Just msg2) else nothing _ -> nothing else nothing -- show appropriate update message if applicable return $ case getFirst (foldMap (First . snd) newBuffers) of Just msg -> (statusLinesA %~ DelayList.insert msg) e0 {buffers = fmap fst newBuffers} Nothing -> e0 where msg1 = (1, (["File was changed by a concurrent process, reloaded!"], strongHintStyle)) msg2 = (1, (["Disk version changed by a concurrent process"], strongHintStyle)) msg3 x = (1, (["File changed on disk to unknown encoding, not updating buffer: " <> x], strongHintStyle)) visibleBuffers = bufkey <$> windows e0 fileModTime f = posixSecondsToUTCTime . realToFrac . modificationTime <$> getFileStatus f runDummy b act = snd $ runBuffer (dummyWindow $ bkey b) b act -- | Hide selection, clear "syntax dirty" flag (as appropriate). clearAllSyntaxAndHideSelection :: Editor -> Editor clearAllSyntaxAndHideSelection = buffersA %~ fmap (clearSyntax . clearHighlight) where clearHighlight fb = -- if there were updates, then hide the selection. let h = view highlightSelectionA fb us = view pendingUpdatesA fb in highlightSelectionA .~ (h && null us) $ fb -- Focus syntax tree on the current window, for all visible buffers. focusAllSyntax :: Editor -> Editor focusAllSyntax e6 = buffersA %~ fmap (\b -> focusSyntax (regions b) b) $ e6 where regions b = M.fromList [(wkey w, winRegion w) | w <- toList $ windows e6, bufkey w == bkey b] -- Why bother filtering the region list? After all the trees -- are lazily computed. Answer: focusing is an incremental -- algorithm. Each "focused" path depends on the previous -- one. If we left unforced focused paths, we'd create a -- long list of thunks: a memory leak. -- | Redraw refreshEditor :: YiM () refreshEditor = onYiVar $ \yi var -> do let cfg = yiConfig yi runOnWins a = runEditor cfg (do ws <- use windowsA forM ws $ flip withWindowE a) style = configScrollStyle $ configUI cfg let scroll e3 = let (e4, relayout) = runOnWins (snapScreenB style) e3 in -- Scroll windows to show current points as appropriate -- Do another layout pass if there was any scrolling; (if or relayout then UI.layout (yiUi yi) else return) e4 e7 <- (if configCheckExternalChangesObsessively cfg then checkFileChanges else return) (yiEditor var) >>= return . clearAllSyntaxAndHideSelection >>= -- Adjust window sizes according to UI info UI.layout (yiUi yi) >>= scroll >>= -- Adjust point according to the current layout; return . fst . runOnWins snapInsB >>= return . focusAllSyntax >>= -- Clear "pending updates" and "followUp" from buffers. return . (buffersA %~ fmap (clearUpdates . clearFollow)) -- Display the new state of the editor UI.refresh (yiUi yi) e7 -- Terminate stale processes. terminateSubprocesses (staleProcess $ buffers e7) yi var {yiEditor = e7} where clearUpdates = pendingUpdatesA .~ mempty clearFollow = pointFollowsWindowA .~ mempty -- Is this process stale? (associated with a deleted buffer) staleProcess bs p = not (bufRef p `M.member` bs) -- | Suspend the program suspendEditor :: YiM () suspendEditor = withUI UI.suspend ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- | Pipe a string through an external command, returning the stdout -- chomp any trailing newline (is this desirable?) -- -- Todo: variants with marks? -- runProcessWithInput :: String -> String -> YiM String runProcessWithInput cmd inp = do let (f:args) = splitOn " " cmd (_,out,_err) <- liftBase $ readProcessWithExitCode f args inp return (chomp "\n" out) ------------------------------------------------------------------------ -- | Same as 'Yi.Editor.printMsg', but do nothing instead of printing @()@ msgEditor :: T.Text -> YiM () msgEditor "()" = return () msgEditor s = printMsg s runAction :: Action -> YiM () runAction (YiA act) = act >>= msgEditor . showT runAction (EditorA act) = withEditor act >>= msgEditor . showT runAction (BufferA act) = withCurrentBuffer act >>= msgEditor . showT -- | Show an error on the status line and log it. errorEditor :: T.Text -> YiM () errorEditor s = do printStatus (["error: " <> s], errorStyle) logPutStrLn $ "errorEditor: " <> s -- | Close the current window. -- If this is the last window open, quit the program. -- -- CONSIDER: call quitEditor when there are no other window in the -- 'interactive' function. (Not possible since the windowset type -- disallows it -- should it be relaxed?) closeWindow :: YiM () closeWindow = do winCount <- withEditor $ uses windowsA PL.length tabCount <- withEditor $ uses tabsA PL.length when (winCount == 1 && tabCount == 1) quitEditor withEditor tryCloseE -- | This is a like 'closeWindow' but with emacs behaviour of C-x 0: -- if we're trying to close the minibuffer or last buffer in the -- editor, then just print a message warning the user about it rather -- closing mini or quitting editor. closeWindowEmacs :: YiM () closeWindowEmacs = do wins <- withEditor $ use windowsA let winCount = PL.length wins tabCount <- withEditor $ uses tabsA PL.length case () of _ | winCount == 1 && tabCount == 1 -> printMsg "Attempt to delete sole ordinary window" | isMini (PL._focus wins) -> printMsg "Attempt to delete the minibuffer" | otherwise -> withEditor tryCloseE onYiVar :: (Yi -> YiVar -> IO (YiVar, a)) -> YiM a onYiVar f = do yi <- ask io $ modifyMVar (yiVar yi) (f yi) -- | Kill a given subprocess terminateSubprocesses :: (SubprocessInfo -> Bool) -> Yi -> YiVar -> IO (YiVar, ()) terminateSubprocesses shouldTerminate _yi var = do let (toKill, toKeep) = partition (shouldTerminate . snd) $ M.assocs $ yiSubprocesses var void $ forM toKill $ terminateProcess . procHandle . snd return (var & yiSubprocessesA .~ M.fromList toKeep, ()) -- | Start a subprocess with the given command and arguments. startSubprocess :: FilePath -> [String] -> (Either SomeException ExitCode -> YiM x) -> YiM BufferRef startSubprocess cmd args onExit = onYiVar $ \yi var -> do let (e', bufref) = runEditor (yiConfig yi) (printMsg ("Launched process: " <> T.pack cmd) >> newEmptyBufferE (MemBuffer bufferName)) (yiEditor var) procid = yiSubprocessIdSupply var + 1 procinfo <- createSubprocess cmd args bufref startSubprocessWatchers procid procinfo yi onExit return (var & yiEditorA .~ e' & yiSubprocessIdSupplyA .~ procid & yiSubprocessesA %~ M.insert procid procinfo , bufref) where bufferName = T.unwords [ "output from", T.pack cmd, showT args ] startSubprocessWatchers :: SubprocessId -> SubprocessInfo -> Yi -> (Either SomeException ExitCode -> YiM x) -> IO () startSubprocessWatchers procid procinfo yi onExit = mapM_ (\(labelSuffix, run) -> do threadId <- forkOS run labelThread threadId (procCmd procinfo ++ labelSuffix)) ([("Err", pipeToBuffer (hErr procinfo) (send . append True)) | separateStdErr procinfo] ++ [("Out", pipeToBuffer (hOut procinfo) (send . append False)), ("Exit", waitForExit (procHandle procinfo) >>= reportExit)]) where send :: YiM () -> IO () send a = yiOutput yi MustRefresh [makeAction a] -- TODO: This 'String' here is due to 'pipeToBuffer' but I don't -- know how viable it would be to read from a process as Text. -- Probably not worse than String but needs benchmarking. append :: Bool -> String -> YiM () append atMark = withEditor . appendToBuffer atMark (bufRef procinfo) . R.fromString reportExit :: Either SomeException ExitCode -> IO () reportExit ec = send $ do append True $ "Process exited with " <> show ec removeSubprocess procid void $ onExit ec removeSubprocess :: SubprocessId -> YiM () removeSubprocess procid = asks yiVar >>= liftBase . flip modifyMVar_ (pure . (yiSubprocessesA %~ M.delete procid)) -- | Appends a 'R.YiString' to the given buffer. -- -- TODO: Figure out and document the Bool here. Probably to do with -- 'startSubprocessWatchers'. appendToBuffer :: Bool -- Something to do with stdout/stderr? -> BufferRef -- ^ Buffer to append to -> R.YiString -- ^ Text to append -> EditorM () appendToBuffer atErr bufref s = withGivenBuffer bufref $ do -- We make sure stdout is always after stderr. This ensures that -- the output of the two pipe do not get interleaved. More -- importantly, GHCi prompt should always come after the error -- messages. me <- getMarkB (Just "StdERR") mo <- getMarkB (Just "StdOUT") let mms = if atErr then [mo, me] else [mo] forM_ mms (`modifyMarkB` (markGravityAA .~ Forward)) insertNAt s =<< use (markPointA (if atErr then me else mo)) forM_ mms (`modifyMarkB` (markGravityAA .~ Backward)) sendToProcess :: BufferRef -> String -> YiM () sendToProcess bufref s = do yi <- ask find ((== bufref) . bufRef) . yiSubprocesses <$> liftBase (readMVar (yiVar yi)) >>= \case Just subProcessInfo -> io $ hPutStr (hIn subProcessInfo) s Nothing -> printMsg "Could not get subProcessInfo in sendToProcess" pipeToBuffer :: Handle -> (String -> IO ()) -> IO () pipeToBuffer h append = void . ignoringException . forever $ do _ <- hWaitForInput h (-1) r <- readAvailable h append r waitForExit :: ProcessHandle -> IO (Either SomeException ExitCode) waitForExit ph = handle (\e -> return (Left (e :: SomeException))) $ do mec <- getProcessExitCode ph case mec of Nothing -> threadDelay (500*1000) >> waitForExit ph Just ec -> return (Right ec) withSyntax :: (Show x, YiAction a x) => (forall syntax. Mode syntax -> syntax -> a) -> YiM () withSyntax f = do b <- gets currentBuffer act <- withGivenBuffer b $ withSyntaxB f runAction $ makeAction act userForceRefresh :: YiM () userForceRefresh = withUI UI.userForceRefresh yi-core-0.19.4/src/Yi/Debug.hs0000644000000000000000000000643007346545000014102 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Debug -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Debug utilities used throughout Yi. module Yi.Debug ( initDebug, trace, traceM, traceM_, logPutStrLn , logError, logStream, Yi.Debug.error ) where import Control.Concurrent ( dupChan, getChanContents, forkIO, myThreadId, Chan ) import Control.Monad.Base ( liftBase, MonadBase ) import Data.IORef ( readIORef, writeIORef, IORef, newIORef ) import Data.Monoid ( (<>) ) import qualified Data.Text as T ( pack, snoc, unpack, Text ) import GHC.Conc ( labelThread ) import System.IO ( hFlush, hPutStrLn, IOMode(WriteMode), openFile, Handle ) import System.IO.Unsafe ( unsafePerformIO ) #if __GLASGOW_HASKELL__ < 710 import Data.Time (formatTime, getCurrentTime) import System.Locale (defaultTimeLocale) #else import Data.Time (formatTime, getCurrentTime, defaultTimeLocale) #endif dbgHandle :: IORef (Maybe Handle) dbgHandle = unsafePerformIO $ newIORef Nothing {-# NOINLINE dbgHandle #-} -- | Set the file to which debugging output should be written. Though this -- is called /init/Debug. -- Debugging output is not created by default (i.e., if this function -- is never called.) -- The target file can not be changed, nor debugging disabled. initDebug :: FilePath -> IO () initDebug f = do hndl <- readIORef dbgHandle case hndl of Nothing -> do openFile f WriteMode >>= writeIORef dbgHandle . Just logPutStrLn "Logging initialized." Just _ -> logPutStrLn "Attempt to re-initialize the logging system." -- | Outputs the given string before returning the second argument. trace :: T.Text -> a -> a trace s e = unsafePerformIO $ logPutStrLn s >> return e {-# NOINLINE trace #-} error :: T.Text -> a error s = unsafePerformIO $ logPutStrLn s >> Prelude.error (T.unpack s) logPutStrLn :: MonadBase IO m => T.Text -> m () logPutStrLn s = liftBase $ readIORef dbgHandle >>= \case Nothing -> return () Just h -> do time <- getCurrentTime tId <- myThreadId let m = show tId ++ " " ++ T.unpack s hPutStrLn h $ formatTime defaultTimeLocale rfc822DateFormat' time ++ m hFlush h where -- A bug in rfc822DateFormat makes us use our own format string rfc822DateFormat' = "%a, %d %b %Y %H:%M:%S %Z" logError :: MonadBase IO m => T.Text -> m () logError s = logPutStrLn $ "error: " <> s logStream :: Show a => T.Text -> Chan a -> IO () logStream msg ch = do logPutStrLn $ "Logging stream " <> msg logThreadId <- forkIO $ logStreamThread msg ch labelThread logThreadId "LogStream" logStreamThread :: Show a => T.Text -> Chan a -> IO () logStreamThread msg ch = do stream <- getChanContents =<< dupChan ch mapM_ logPutStrLn [ msg `T.snoc` '(' <> T.pack (show i) `T.snoc` ')' <> T.pack (show event) | (event, i) <- zip stream [(0::Int)..] ] -- | Traces @x@ and returns @y@. traceM :: Monad m => T.Text -> a -> m a traceM x y = trace x $ return y -- | Like traceM, but returns (). traceM_ :: Monad m => T.Text -> m () traceM_ x = traceM x () yi-core-0.19.4/src/Yi/Dired.hs0000644000000000000000000013067507346545000014114 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} {-| Module : Yi.Dired License : GPL-2 Maintainer : yi-devel@googlegroups.com Stability : experimental Portability : portable A simple implementation for Yi. = TODO * add more comments * Support symlinks * Mark operations * search * Improve the colouring to show * loaded buffers * .hs files * marked files * Fix old mod dates (> 6months) to show year * Fix the 'number of links' field to show actual values not just 1... * Automatic support for browsing .zip, .gz files etc... -} module Yi.Dired ( dired , diredDir , diredDirBuffer , editFile ) where import GHC.Generics (Generic) import Control.Applicative ((<|>)) import Control.Category ((>>>)) import Control.Exc (orException, printingException) import Lens.Micro.Platform (makeLenses, use, (%~), (&), (.=), (.~), (^.)) import Control.Monad (foldM, unless, void, when) import Control.Monad.Reader (asks) import qualified Data.Attoparsec.Text as P import Data.Binary (Binary) import Data.Char (toLower) import Data.Default (Default, def) import Data.Foldable (find, foldl') import Data.List (any, elem, sum, transpose) import qualified Data.Map as M (Map, assocs, delete, empty, findWithDefault, fromList, insert, keys, lookup, map, mapKeys, union, (!)) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, pack, unpack) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Typeable (Typeable) import System.CanonicalizePath (canonicalizePath) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getDirectoryContents, getPermissions, removeDirectoryRecursive, writable) import System.FilePath (dropTrailingPathSeparator, equalFilePath, isAbsolute, takeDirectory, takeFileName, ()) import System.FriendlyPath (userToCanonPath) import System.PosixCompat.Files (FileStatus, fileExist, fileGroup, fileMode, fileOwner, fileSize, getSymbolicLinkStatus, groupExecuteMode, groupReadMode, groupWriteMode, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, isSocket, isSymbolicLink, linkCount, modificationTime, otherExecuteMode, otherReadMode, otherWriteMode, ownerExecuteMode, ownerReadMode, ownerWriteMode, readSymbolicLink, readSymbolicLink, removeLink, rename, unionFileModes) import System.PosixCompat.Types (FileMode, GroupID, UserID) #ifndef mingw32_HOST_OS #if MIN_VERSION_unix(2,8,0) import System.Posix.User.ByteString (GroupEntry(GroupEntry), UserEntry(UserEntry)) import System.Posix.User (getAllGroupEntries, #else import System.Posix.User (GroupEntry(..), UserEntry(..),getAllGroupEntries, #endif getAllUserEntries, getGroupEntryForID, getUserEntryForID, groupID, userID, userName, groupName) #endif import Text.Printf (printf) import Yi.Buffer import Yi.Config (modeTable) import Yi.Core (errorEditor) import Yi.Editor import Yi.Keymap (Keymap, YiM, topKeymapA) import Yi.Keymap.Keys import Yi.MiniBuffer (noHint, spawnMinibufferE, withMinibuffer, withMinibufferFree) import Yi.Misc (getFolder, promptFile) import Yi.Monad (gets) import qualified Yi.Rope as R import Yi.String (showT) import Yi.Style import Yi.Types (YiVariable, yiConfig) import Yi.Utils (io, makeLensesWithSuffix) #if __GLASGOW_HASKELL__ < 710 import System.Locale (defaultTimeLocale) import Data.Time (UTCTime, formatTime, getCurrentTime) #else import Data.Time (UTCTime, formatTime, getCurrentTime, defaultTimeLocale) #endif -- Have no idea how to keep track of this state better, so here it is ... data DiredOpState = DiredOpState { _diredOpSucCnt :: !Int -- ^ keep track of the num of successful operations , _diredOpForAll :: Bool -- ^ if True, DOChoice will be bypassed } deriving (Show, Eq, Typeable, Generic) instance Default DiredOpState where def = DiredOpState { _diredOpSucCnt = 0, _diredOpForAll = False } instance Binary DiredOpState instance YiVariable DiredOpState makeLenses ''DiredOpState data DiredFileInfo = DiredFileInfo { permString :: R.YiString , numLinks :: Integer , owner :: R.YiString , grp :: R.YiString , sizeInBytes :: Integer , modificationTimeString :: R.YiString } deriving (Show, Eq, Typeable, Generic) data DiredEntry = DiredFile DiredFileInfo | DiredDir DiredFileInfo | DiredSymLink DiredFileInfo R.YiString | DiredSocket DiredFileInfo | DiredBlockDevice DiredFileInfo | DiredCharacterDevice DiredFileInfo | DiredNamedPipe DiredFileInfo | DiredNoInfo deriving (Show, Eq, Typeable, Generic) -- | Alias serving as documentation of some arguments. We keep most -- paths as 'R.YiString' for the sole reason that we'll have to render -- them. type DiredFilePath = R.YiString -- | Handy alias for 'DiredEntry' map. type DiredEntries = M.Map DiredFilePath DiredEntry data DiredState = DiredState { diredPath :: FilePath -- ^ The full path to the directory being viewed -- FIXME Choose better data structure for Marks... , diredMarks :: M.Map FilePath Char -- ^ Map values are just leafnames, not full paths , diredEntries :: DiredEntries -- ^ keys are just leafnames, not full paths , diredFilePoints :: [(Point,Point,FilePath)] -- ^ position in the buffer where filename is , diredNameCol :: Int -- ^ position on line where filename is (all pointA are this col) , diredCurrFile :: FilePath -- ^ keep the position of pointer (for refreshing dired buffer) } deriving (Show, Eq, Typeable, Generic) makeLensesWithSuffix "A" ''DiredState instance Binary DiredState instance Default DiredState where def = DiredState { diredPath = mempty , diredMarks = mempty , diredEntries = mempty , diredFilePoints = mempty , diredNameCol = 0 , diredCurrFile = mempty } instance YiVariable DiredState instance Binary DiredEntry instance Binary DiredFileInfo -- | If file exists, read contents of file into a new buffer, otherwise -- creating a new empty buffer. Replace the current window with a new -- window onto the new buffer. -- -- If the file is already open, just switch to the corresponding buffer. -- -- Need to clean up semantics for when buffers exist, and how to attach -- windows to buffers. -- -- @Yi.File@ module re-exports this, you probably want to import that -- instead. -- -- In case of a decoding failure, failure message is returned instead -- of the 'BufferRef'. editFile :: FilePath -> YiM (Either T.Text BufferRef) editFile filename = do f <- io $ userToCanonPath filename dupBufs <- filter (maybe False (equalFilePath f) . file) <$> gets bufferSet dirExists <- io $ doesDirectoryExist f fileExists <- io $ doesFileExist f b <- case dupBufs of [] -> if dirExists then Right <$> diredDirBuffer f else do nb <- if fileExists then fileToNewBuffer f else Right <$> newEmptyBuffer f case nb of Left m -> return $ Left m Right buf -> Right <$> setupMode f buf (h:_) -> return . Right $ bkey h case b of Left m -> return $ Left m Right bf -> withEditor (switchToBufferE bf >> addJumpHereE) >> return b where fileToNewBuffer :: FilePath -> YiM (Either T.Text BufferRef) fileToNewBuffer f = io getCurrentTime >>= \n -> io (R.readFile f) >>= \case Left m -> return $ Left m Right contents -> do permissions <- io $ getPermissions f b <- stringToNewBuffer (FileBuffer f) contents withGivenBuffer b $ do markSavedB n unless (writable permissions) (readOnlyA .= True) return $ Right b newEmptyBuffer :: FilePath -> YiM BufferRef newEmptyBuffer f = stringToNewBuffer (FileBuffer f) mempty setupMode :: FilePath -> BufferRef -> YiM BufferRef setupMode f b = do tbl <- asks (modeTable . yiConfig) content <- withGivenBuffer b elemsB let header = R.take 1024 content pc = "-*-" *> P.skipWhile (== ' ') *> P.takeWhile (/= ' ') <* P.skipWhile (== ' ') <* "-*-" <|> P.skip (const True) *> P.skipWhile (/= '-') *> pc hmode = case P.parseOnly pc (R.toText header) of Left _ -> "" Right str -> str Just mode = find (\(AnyMode m) -> modeName m == hmode) tbl <|> find (\(AnyMode m) -> modeApplies m f header) tbl <|> Just (AnyMode emptyMode) case mode of AnyMode newMode -> withGivenBuffer b $ setMode newMode return b bypassReadOnly :: BufferM a -> BufferM a bypassReadOnly f = do ro <- use readOnlyA readOnlyA .= False res <- f readOnlyA .= ro return res filenameColOf :: BufferM () -> BufferM () filenameColOf f = getBufferDyn >>= (.=) preferColA . Just . diredNameCol >> f resetDiredOpState :: YiM () resetDiredOpState = withCurrentBuffer $ putBufferDyn (def :: DiredOpState) incDiredOpSucCnt :: YiM () incDiredOpSucCnt = withCurrentBuffer $ getBufferDyn >>= putBufferDyn . (diredOpSucCnt %~ succ) getDiredOpState :: YiM DiredOpState getDiredOpState = withCurrentBuffer getBufferDyn modDiredOpState :: (DiredOpState -> DiredOpState) -> YiM () modDiredOpState f = withCurrentBuffer $ getBufferDyn >>= putBufferDyn . f -- | Execute the operations -- -- Pass the list of remaining operations down, insert new ops at the -- head if needed procDiredOp :: Bool -> [DiredOp] -> YiM () procDiredOp counting (DORemoveFile f:ops) = do io $ printingException ("Remove file " <> f) (removeLink f) when counting postproc procDiredOp counting ops where postproc = do incDiredOpSucCnt withCurrentBuffer $ diredUnmarkPath (takeFileName f) procDiredOp counting (DORemoveDir f:ops) = do io $ printingException ("Remove directory " <> f) (removeDirectoryRecursive f) -- document suggests removeDirectoryRecursive will follow -- symlinks in f, but it seems not the case, at least on OS X. when counting postproc procDiredOp counting ops where postproc = do incDiredOpSucCnt withCurrentBuffer $ diredUnmarkPath (takeFileName f) procDiredOp _counting (DORemoveBuffer _:_) = undefined -- TODO procDiredOp counting (DOCopyFile o n:ops) = do io $ printingException ("Copy file " <> o) (copyFile o n) when counting postproc procDiredOp counting ops where postproc = do incDiredOpSucCnt withCurrentBuffer $ diredUnmarkPath (takeFileName o) -- TODO: mark copied files with "C" if the target dir's -- dired buffer exists procDiredOp counting (DOCopyDir o n:ops) = do contents <- io $ printingException (concat ["Copy directory ", o, " to ", n]) doCopy subops <- io $ mapM builder $ filter (`notElem` [".", ".."]) contents procDiredOp False subops when counting postproc procDiredOp counting ops where postproc = do incDiredOpSucCnt withCurrentBuffer $ diredUnmarkPath (takeFileName o) -- perform dir copy: create new dir and create other copy ops doCopy :: IO [FilePath] doCopy = do exists <- doesDirectoryExist n when exists $ removeDirectoryRecursive n createDirectoryIfMissing True n getDirectoryContents o -- build actual copy operations builder :: FilePath -> IO DiredOp builder name = do let npath = n name let opath = o name isDir <- doesDirectoryExist opath return $ DOCkOverwrite npath $ getOp isDir opath npath where getOp isDir = if isDir then DOCopyDir else DOCopyFile procDiredOp counting (DORename o n:ops) = do io $ printingException (concat ["Rename ", o, " to ", n]) (rename o n) when counting postproc procDiredOp counting ops where postproc = do incDiredOpSucCnt withCurrentBuffer $ diredUnmarkPath (takeFileName o) procDiredOp counting r@(DOConfirm prompt eops enops:ops) = withMinibuffer (R.toText $ prompt <> " (yes/no)") noHint (act . T.unpack) where act s = case map toLower s of "yes" -> procDiredOp counting (eops <> ops) "no" -> procDiredOp counting (enops <> ops) _ -> procDiredOp counting r -- TODO: show an error msg procDiredOp counting (DOCheck check eops enops:ops) = do res <- io check procDiredOp counting (if res then eops <> ops else enops <> ops) procDiredOp counting (DOCkOverwrite fp op:ops) = do exists <- io $ fileExist fp procDiredOp counting (if exists then newOp:ops else op:ops) where newOp = DOChoice ("Overwrite " <> R.fromString fp <> " ?") op procDiredOp counting (DOInput prompt opGen:ops) = promptFile (R.toText prompt) (act . T.unpack) where act s = procDiredOp counting $ opGen s <> ops procDiredOp counting (DONoOp:ops) = procDiredOp counting ops procDiredOp counting (DOFeedback f:ops) = getDiredOpState >>= f >> procDiredOp counting ops procDiredOp counting r@(DOChoice prompt op:ops) = do st <- getDiredOpState if st ^. diredOpForAll then proceedYes else withEditor_ $ spawnMinibufferE msg (const askKeymap) where msg = R.toText $ prompt <> " (y/n/!/q/h)" askKeymap = choice [ char 'n' ?>>! noAction , char 'y' ?>>! yesAction , char '!' ?>>! allAction , char 'q' ?>>! quit , char 'h' ?>>! help ] noAction = cleanUp >> proceedNo yesAction = cleanUp >> proceedYes allAction = do cleanUp modDiredOpState (diredOpForAll .~ True) proceedYes quit = cleanUp >> printMsg "Quit" help = do printMsg "y: yes, n: no, !: yes on all remaining items, q: quit, h: help" cleanUp procDiredOp counting r -- repeat -- use cleanUp to get back the original buffer cleanUp = withEditor closeBufferAndWindowE proceedYes = procDiredOp counting (op:ops) proceedNo = procDiredOp counting ops procDiredOp _ _ = return () -- | Delete a list of file in the given directory -- -- 1. Ask for confirmation, if yes, perform deletions, otherwise -- showNothing -- -- 2. Confirmation is required for recursive deletion of non-empty -- directory, but only the top level one -- -- 3. Show the number of successful deletions at the end of the execution -- -- 4. TODO: ask confirmation for whether to remove the associated -- buffers when a file is removed askDelFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM () askDelFiles dir fs = case fs of (_x:_) -> do resetDiredOpState -- TODO: show the file name list in new tmp window opList <- io $ sequence ops -- a deletion command is mapped to a list of deletions -- wrapped up by DOConfirm -- TODO: is `counting' necessary here? let ops' = opList <> [DOFeedback showResult] procDiredOp True [DOConfirm prompt ops' [DOFeedback showNothing]] -- no files listed [] -> procDiredOp True [DOFeedback showNothing] where prompt = R.concat [ "Delete " , R.fromString . show $ length fs , " file(s)?" ] ops = map opGenerator fs showResult st = do diredRefresh printMsg $ showT (st ^. diredOpSucCnt) <> " of " <> showT total <> " deletions done" showNothing _ = printMsg "(No deletions requested)" total = length fs opGenerator :: (FilePath, DiredEntry) -> IO DiredOp opGenerator (fn, de) = do exists <- fileExist path if exists then case de of (DiredDir _dfi) -> do isNull <- fmap nullDir $ getDirectoryContents path return $ if isNull then DOConfirm recDelPrompt [DORemoveDir path] [DONoOp] else DORemoveDir path _ -> return (DORemoveFile path) else return DONoOp where path = dir fn recDelPrompt = "Recursive delete of " <> R.fromString fn <> "?" -- Test the emptyness of a folder nullDir :: [FilePath] -> Bool nullDir = Data.List.any (not . flip Data.List.elem [".", ".."]) diredDoDel :: YiM () diredDoDel = do dir <- currentDir maybefile <- withCurrentBuffer fileFromPoint case maybefile of Just (fn, de) -> askDelFiles dir [(fn, de)] Nothing -> noFileAtThisLine diredDoMarkedDel :: YiM () diredDoMarkedDel = do dir <- currentDir fs <- markedFiles (== 'D') askDelFiles dir fs diredKeymap :: Keymap -> Keymap diredKeymap = important $ withArg mainMap where -- produces a copy of the map allowing for C-u withArg :: (Maybe Int -> Keymap) -> Keymap withArg k = choice [ ctrlCh 'u' ?>> k (Just 1) , k Nothing ] mainMap :: Maybe Int -> Keymap mainMap univArg = choice [ char 'p' ?>>! filenameColOf lineUp , oneOf [char 'n', char ' '] >>! filenameColOf lineDown , char 'd' ?>>! diredMarkDel , char 'g' ?>>! diredRefresh , char 'm' ?>>! diredMark , char '^' ?>>! diredUpDir , char '+' ?>>! diredCreateDir , char 'q' ?>>! ((deleteBuffer =<< gets currentBuffer) :: EditorM ()) , char 'x' ?>>! diredDoMarkedDel , oneOf [ctrl $ char 'm', spec KEnter, char 'f', char 'e'] >>! diredLoad -- Currently ‘o’ misbehaves, seems this naive method loses -- track of buffers. , char 'o' ?>>! withOtherWindow diredLoad , char 'u' ?>>! diredUnmark Forward , spec KBS ?>>! diredUnmark Backward , char 'D' ?>>! diredDoDel , char 'U' ?>>! diredUnmarkAll , char 'R' ?>>! diredRename , char 'C' ?>>! diredCopy , char '*' ?>> multiMarks univArg ] multiMarks :: Maybe Int -> Keymap multiMarks univArg = choice [ char '!' ?>>! diredUnmarkAll , char '@' ?>>! diredMarkSymlinks univArg , char '/' ?>>! diredMarkDirectories univArg , char 't' ?>>! diredToggleAllMarks ] dired :: YiM () dired = do printMsg "Dired..." maybepath <- withCurrentBuffer $ gets file dir <- io $ getFolder maybepath void $ editFile dir diredDir :: FilePath -> YiM () diredDir dir = void (diredDirBuffer dir) diredDirBuffer :: FilePath -> YiM BufferRef diredDirBuffer d = do -- Emacs doesn't follow symlinks, probably Yi shouldn't do too dir <- io $ canonicalizePath d b <- stringToNewBuffer (FileBuffer dir) mempty withEditor $ switchToBufferE b withCurrentBuffer $ do state <- getBufferDyn putBufferDyn (state & diredPathA .~ dir) directoryContentA .= True diredRefresh return b -- | Write the contents of the supplied directory into the current -- buffer in dired format diredRefresh :: YiM () diredRefresh = do dState <- withCurrentBuffer getBufferDyn let dir = diredPath dState -- Scan directory di <- io $ diredScanDir dir currFile <- if null (diredFilePoints dState) then return "" else do maybefile <- withCurrentBuffer fileFromPoint case maybefile of Just (fp, _) -> return fp Nothing -> return "" let ds = diredEntriesA .~ di $ diredCurrFileA .~ currFile $ dState -- Compute results let dlines = linesToDisplay ds (strss, stys, strs) = unzip3 dlines strss' = transpose $ map doPadding $ transpose strss namecol = if null strss' then 0 else let l1details = init $ head strss' in Data.List.sum (map R.length l1details) + length l1details -- Set buffer contents withCurrentBuffer $ do -- Clear buffer readOnlyA .= False ---- modifications begin here deleteRegionB =<< regionOfB Document -- Write Header insertN $ R.fromString dir <> ":\n" p <- pointB -- paint header addOverlayB $ mkOverlay "dired" (mkRegion 0 (p-2)) headStyle "" ptsList <- mapM insertDiredLine $ zip3 strss' stys strs putBufferDyn $ diredFilePointsA .~ ptsList $ diredNameColA .~ namecol $ ds -- Colours for Dired come from overlays not syntax highlighting modifyMode $ modeKeymapA .~ topKeymapA %~ diredKeymap >>> modeNameA .~ "dired" diredRefreshMark ---- no modifications after this line readOnlyA .= True when (null currFile) $ moveTo (p-2) case getRow currFile ptsList of Just rpos -> filenameColOf $ moveTo rpos Nothing -> filenameColOf lineDown where getRow fp recList = lookup fp (map (\(a,_b,c)->(c,a)) recList) headStyle = const (withFg grey) doPadding :: [DRStrings] -> [R.YiString] doPadding drs = map (pad ((maximum . map drlength) drs)) drs pad _n (DRPerms s) = s pad n (DRLinks s) = R.replicate (max 0 (n - R.length s)) " " <> s pad n (DROwners s) = s <> R.replicate (max 0 (n - R.length s)) " " <> " " pad n (DRGroups s) = s <> R.replicate (max 0 (n - R.length s)) " " pad n (DRSizes s) = R.replicate (max 0 (n - R.length s)) " " <> s pad n (DRDates s) = R.replicate (max 0 (n - R.length s)) " " <> s pad _n (DRFiles s) = s -- Don't right-justify the filename drlength = R.length . undrs -- | Returns a tuple containing the textual region (the end of) which -- is used for 'click' detection and the FilePath of the file -- represented by that textual region insertDiredLine :: ([R.YiString], StyleName, R.YiString) -> BufferM (Point, Point, FilePath) insertDiredLine (fields, sty, filenm) = bypassReadOnly $ do insertN . R.unwords $ init fields p1 <- pointB insertN $ ' ' `R.cons` last fields p2 <- pointB newlineB addOverlayB (mkOverlay "dired" (mkRegion p1 p2) sty "") return (p1, p2, R.toString filenm) data DRStrings = DRPerms {undrs :: R.YiString} | DRLinks {undrs :: R.YiString} | DROwners {undrs :: R.YiString} | DRGroups {undrs :: R.YiString} | DRSizes {undrs :: R.YiString} | DRDates {undrs :: R.YiString} | DRFiles {undrs :: R.YiString} -- | Return a List of (prefix, -- fullDisplayNameIncludingSourceAndDestOfLink, style, filename) linesToDisplay :: DiredState -> [([DRStrings], StyleName, R.YiString)] linesToDisplay dState = map (uncurry lineToDisplay) (M.assocs entries) where entries = diredEntries dState lineToDisplay k (DiredFile v) = (l " -" v <> [DRFiles k], defaultStyle, k) lineToDisplay k (DiredDir v) = (l " d" v <> [DRFiles k], const (withFg blue), k) lineToDisplay k (DiredSymLink v s) = (l " l" v <> [DRFiles $ k <> " -> " <> s], const (withFg cyan), k) lineToDisplay k (DiredSocket v) = (l " s" v <> [DRFiles k], const (withFg magenta), k) lineToDisplay k (DiredCharacterDevice v) = (l " c" v <> [DRFiles k], const (withFg yellow), k) lineToDisplay k (DiredBlockDevice v) = (l " b" v <> [DRFiles k], const (withFg yellow), k) lineToDisplay k (DiredNamedPipe v) = (l " p" v <> [DRFiles k], const (withFg brown), k) lineToDisplay k DiredNoInfo = ([DRFiles $ k <> " : Not a file/dir/symlink"], defaultStyle, k) l pre v = [DRPerms $ pre <> permString v, DRLinks . R.fromString $ printf "%4d" (numLinks v), DROwners $ owner v, DRGroups $ grp v, DRSizes . R.fromString $ printf "%8d" (sizeInBytes v), DRDates $ modificationTimeString v] -- | Return dired entries for the contents of the supplied directory diredScanDir :: FilePath -> IO DiredEntries diredScanDir dir = do files <- getDirectoryContents dir foldM (lineForFile dir) M.empty files where lineForFile :: FilePath -> DiredEntries -> FilePath -> IO DiredEntries #ifndef mingw32_HOST_OS lineForFile d m f = do let fp = d f fileStatus <- getSymbolicLinkStatus fp dfi <- lineForFilePath fp fileStatus let islink = isSymbolicLink fileStatus linkTarget <- if islink then readSymbolicLink fp else return mempty let de | isDirectory fileStatus = DiredDir dfi | isRegularFile fileStatus = DiredFile dfi | islink = DiredSymLink dfi (R.fromString linkTarget) | isSocket fileStatus = DiredSocket dfi | isCharacterDevice fileStatus = DiredCharacterDevice dfi | isBlockDevice fileStatus = DiredBlockDevice dfi | isNamedPipe fileStatus = DiredNamedPipe dfi | otherwise = DiredNoInfo return $ M.insert (R.fromString f) de m lineForFilePath :: FilePath -> FileStatus -> IO DiredFileInfo lineForFilePath fp fileStatus = do let modTimeStr = R.fromString . shortCalendarTimeToString . posixSecondsToUTCTime . realToFrac $ modificationTime fileStatus let uid = fileOwner fileStatus gid = fileGroup fileStatus fn = takeFileName fp _filenm <- if isSymbolicLink fileStatus then return . ((fn <> " -> ") <>) =<< readSymbolicLink fp else return fn ownerEntry <- orException (getUserEntryForID uid) (fmap (scanForUid uid) getAllUserEntries) groupEntry <- orException (getGroupEntryForID gid) (fmap (scanForGid gid) getAllGroupEntries) let fmodeStr = (modeString . fileMode) fileStatus sz = toInteger $ fileSize fileStatus ownerStr = R.fromString $ userName ownerEntry groupStr = R.fromString $ groupName groupEntry numOfLinks = toInteger $ linkCount fileStatus return DiredFileInfo { permString = fmodeStr , numLinks = numOfLinks , owner = ownerStr , grp = groupStr , sizeInBytes = sz , modificationTimeString = modTimeStr} -- | Needed on Mac OS X 10.4 scanForUid :: UserID -> [UserEntry] -> UserEntry scanForUid uid entries = fromMaybe missingEntry $ find ((uid ==) . userID) entries where missingEntry = UserEntry "?" mempty uid 0 mempty mempty mempty -- | Needed on Mac OS X 10.4 scanForGid :: GroupID -> [GroupEntry] -> GroupEntry scanForGid gid entries = fromMaybe missingEntry $ find ((gid ==) . groupID) entries where missingEntry = GroupEntry "?" mempty gid mempty #else -- has been the default for Windows anyway, so just directly do it without unix-compat lineForFile _ m f = return $ M.insert (R.fromString f) DiredNoInfo m #endif modeString :: FileMode -> R.YiString modeString fm = "" <> strIfSet "r" ownerReadMode <> strIfSet "w" ownerWriteMode <> strIfSet "x" ownerExecuteMode <> strIfSet "r" groupReadMode <> strIfSet "w" groupWriteMode <> strIfSet "x" groupExecuteMode <> strIfSet "r" otherReadMode <> strIfSet "w" otherWriteMode <> strIfSet "x" otherExecuteMode where strIfSet s mode = if fm == (fm `unionFileModes` mode) then s else "-" shortCalendarTimeToString :: UTCTime -> String shortCalendarTimeToString = formatTime defaultTimeLocale "%b %d %H:%M" -- Default Filter: omit files ending in '~' or '#' and also '.' and '..'. -- TODO: customizable filters? --diredOmitFile :: String -> Bool --diredOmitFile = undefined diredMark :: BufferM () diredMark = diredMarkWithChar '*' lineDown diredMarkDel :: BufferM () diredMarkDel = diredMarkWithChar 'D' lineDown -- | Generic mark toggler. diredMarkKind :: Maybe Int -- ^ universal argument, usually indicating whether -- to mark or unmark. Here ‘Just …’ is taken as -- unmark. -> (DiredFilePath -> DiredEntry -> Bool) -- ^ Picks which entries to consider -> Char -- ^ Character used for marking. Pass garbage if -- unmarking. -> BufferM () diredMarkKind m p c = bypassReadOnly $ do dState <- getBufferDyn let es = M.assocs $ diredEntries dState ms = M.fromList [ (R.toString fp, c) | (fp, e) <- es, p fp e ] putBufferDyn (dState & diredMarksA %~ run ms) diredRefreshMark where run :: M.Map FilePath Char -> M.Map FilePath Char -> M.Map FilePath Char run ms cms = case m of Nothing -> M.union ms cms Just _ -> deleteKeys cms (M.keys ms) diredMarkSymlinks :: Maybe Int -> BufferM () diredMarkSymlinks m = diredMarkKind m p '*' where p _ DiredSymLink {} = True p _ _ = False diredMarkDirectories :: Maybe Int -> BufferM () diredMarkDirectories m = diredMarkKind m p '*' where p "." DiredDir {} = False p ".." DiredDir {} = False p _ DiredDir {} = True p _ _ = False diredToggleAllMarks :: BufferM () diredToggleAllMarks = bypassReadOnly $ do dState <- getBufferDyn let es = diredEntries dState putBufferDyn (dState & diredMarksA %~ tm es) diredRefreshMark where -- Get all entries, filter out the ones that are marked already, -- then mark everything that remains, in effect toggling the -- marks. tm :: DiredEntries -> M.Map FilePath Char -> M.Map FilePath Char tm de ms = let unmarked = deleteKeys (M.mapKeys R.toString de) (M.keys ms) in M.map (const '*') unmarked -- | Delete all the keys from the map. deleteKeys :: Ord k => M.Map k v -> [k] -> M.Map k v deleteKeys = foldl' (flip M.delete) diredMarkWithChar :: Char -> BufferM () -> BufferM () diredMarkWithChar c mv = bypassReadOnly $ fileFromPoint >>= \case Just (fn, _de) -> do state <- getBufferDyn putBufferDyn (state & diredMarksA %~ M.insert fn c) filenameColOf mv diredRefreshMark Nothing -> filenameColOf mv diredRefreshMark :: BufferM () diredRefreshMark = do b <- pointB dState <- getBufferDyn let posDict = diredFilePoints dState markMap = diredMarks dState draw (pos, _, fn) = case M.lookup fn markMap of Just mark -> do moveTo pos >> moveToSol >> insertB mark >> deleteN 1 e <- pointB addOverlayB $ mkOverlay "dired" (mkRegion (e - 1) e) (styleOfMark mark) "" Nothing -> -- for deleted marks moveTo pos >> moveToSol >> insertN " " >> deleteN 1 mapM_ draw posDict moveTo b where styleOfMark '*' = const (withFg green) styleOfMark 'D' = const (withFg red) styleOfMark _ = defaultStyle -- | Removes mark from current file (if any) and moves in the -- specified direction. diredUnmark :: Direction -- ^ Direction to move in after unmarking -> BufferM () diredUnmark d = bypassReadOnly $ do let lineDir = case d of { Forward -> lineDown; Backward -> lineUp; } fileFromPoint >>= \case Just (fn, _de) -> do diredUnmarkPath fn filenameColOf lineDir diredRefreshMark Nothing -> filenameColOf lineDir diredUnmarkPath :: FilePath -> BufferM() diredUnmarkPath fn = getBufferDyn >>= putBufferDyn.(diredMarksA %~ M.delete fn) diredUnmarkAll :: BufferM () diredUnmarkAll = bypassReadOnly $ do getBufferDyn >>= putBufferDyn.(diredMarksA .~ M.empty) filenameColOf $ return () diredRefreshMark currentDir :: YiM FilePath currentDir = diredPath <$> withCurrentBuffer getBufferDyn -- | move selected files in a given directory to the target location given -- by user input -- -- if multiple source -- then if target is not a existing dir -- then error -- else move source files into target dir -- else if target is dir -- then if target exist -- then move source file into target dir -- else if source is dir and parent of target exists -- then move source to target -- else error -- else if parent of target exist -- then move source to target -- else error askRenameFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM () askRenameFiles dir fs = case fs of [_x] -> do resetDiredOpState procDiredOp True [DOInput prompt sOpIsDir] _x:_ -> do resetDiredOpState procDiredOp True [DOInput prompt mOpIsDirAndExists] [] -> procDiredOp True [DOFeedback showNothing] where mkErr t = return . DOFeedback . const $ errorEditor t prompt = "Move " <> R.fromString (show total) <> " item(s) to:" mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps] where posOps = map builder fs <> [DOFeedback showResult] negOps = mkErr $ T.pack t <> " is not directory!" builder (fn, _de) = let old = dir fn new = t fn in DOCkOverwrite new (DORename old new) sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirRename] where (fn, _) = head fs -- the only item posOps = [DOCkOverwrite new (DORename old new), DOFeedback showResult] where new = t fn old = dir fn sOpDirRename = [DOCheck ckParentDir posOps' negOps, DOFeedback showResult] where posOps' = [DOCkOverwrite new (DORename old new)] p = "Cannot move " <> T.pack old <> " to " <> T.pack new negOps = mkErr p new = t old = dir fn ps = dropTrailingPathSeparator t ckParentDir = doesDirectoryExist $ takeDirectory ps showResult st = do diredRefresh printMsg $ showT (st ^. diredOpSucCnt) <> " of " <> showT total <> " item(s) moved." showNothing _ = printMsg "Quit" total = length fs -- | copy selected files in a given directory to the target location given -- by user input -- -- askCopyFiles follow the same logic as askRenameFiles, -- except dir and file are done by different DiredOP askCopyFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM () askCopyFiles dir fs = case fs of [_x] -> do resetDiredOpState procDiredOp True [DOInput prompt sOpIsDir] _x:_ -> do resetDiredOpState procDiredOp True [DOInput prompt mOpIsDirAndExists] [] -> procDiredOp True [DOFeedback showNothing] where prompt = "Copy " <> R.fromString (show total) <> " item(s) to:" mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps] where posOps = map builder fs <> [DOFeedback showResult] negOps = [DOFeedback . const $ errorEditor (T.pack t <> " is not directory!")] builder (fn, de) = let old = dir fn new = t fn in DOCkOverwrite new (op4Type de old new) sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirCopy] where (fn, de) = head fs -- the only item posOps = [DOCkOverwrite new (op4Type de old new), DOFeedback showResult] where new = t fn old = dir fn sOpDirCopy = [DOCheck ckParentDir posOps' negOps, DOFeedback showResult] where posOps' = [DOCkOverwrite new (op4Type de old new)] p = "Cannot copy " <> T.pack old <> " to " <> T.pack new negOps = [DOFeedback . const $ errorEditor p] new = t old = dir fn ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t) showResult st = do diredRefresh printMsg $ showT (st ^. diredOpSucCnt) <> " of " <> showT total <> " item(s) copied." showNothing _ = printMsg "Quit" total = length fs op4Type :: DiredEntry -> FilePath -> FilePath -> DiredOp op4Type (DiredDir _) = DOCopyDir op4Type _ = DOCopyFile diredRename :: YiM () diredRename = do dir <- currentDir fs <- markedFiles (== '*') if null fs then do maybefile <- withCurrentBuffer fileFromPoint case maybefile of Just (fn, de) -> askRenameFiles dir [(fn, de)] Nothing -> noFileAtThisLine else askRenameFiles dir fs diredCopy :: YiM () diredCopy = do dir <- currentDir fs <- markedFiles (== '*') if null fs then do maybefile <- withCurrentBuffer fileFromPoint case maybefile of Just (fn, de) -> askCopyFiles dir [(fn, de)] Nothing -> noFileAtThisLine else askCopyFiles dir fs diredLoad :: YiM () diredLoad = do dir <- currentDir withCurrentBuffer fileFromPoint >>= \case Just (fn, de) -> do let sel = dir fn sel' = T.pack sel case de of (DiredFile _dfi) -> do exists <- io $ doesFileExist sel if exists then void $ editFile sel else printMsg $ sel' <> " no longer exists" (DiredDir _dfi) -> do exists <- io $ doesDirectoryExist sel if exists then diredDir sel else printMsg $ sel' <> " no longer exists" (DiredSymLink _dfi dest') -> do let dest = R.toString dest' target = if isAbsolute dest then dest else dir dest existsFile <- io $ doesFileExist target existsDir <- io $ doesDirectoryExist target printMsg $ "Following link:" <> T.pack target if existsFile then void $ editFile target else if existsDir then diredDir target else printMsg $ T.pack target <> " does not exist" (DiredSocket _dfi) -> do exists <- io $ doesFileExist sel printMsg (if exists then "Can't open Socket " <> sel' else sel' <> " no longer exists") (DiredBlockDevice _dfi) -> do exists <- io $ doesFileExist sel printMsg (if exists then "Can't open Block Device " <> sel' else sel' <> " no longer exists") (DiredCharacterDevice _dfi) -> do exists <- io $ doesFileExist sel printMsg (if exists then "Can't open Character Device " <> sel' else sel' <> " no longer exists") (DiredNamedPipe _dfi) -> do exists <- io $ doesFileExist sel printMsg (if exists then "Can't open Pipe " <> sel' else sel' <> " no longer exists") DiredNoInfo -> printMsg $ "No File Info for:" <> sel' Nothing -> noFileAtThisLine noFileAtThisLine :: YiM () noFileAtThisLine = printMsg "(No file at this line)" -- | Extract the filename at point. NB this may fail if the buffer has -- been edited. Maybe use Markers instead. fileFromPoint :: BufferM (Maybe (FilePath, DiredEntry)) fileFromPoint = do p <- pointB dState <- getBufferDyn let candidates = filter (\(_,p2,_)->p <= p2) (diredFilePoints dState) finddef f = M.findWithDefault DiredNoInfo (R.fromString f) return $ case candidates of ((_, _, f):_) -> Just (f, finddef f $ diredEntries dState) _ -> Nothing markedFiles :: (Char -> Bool) -> YiM [(FilePath, DiredEntry)] markedFiles cond = do dState <- withCurrentBuffer getBufferDyn let fs = fst . unzip $ filter (cond . snd) (M.assocs $ diredMarks dState) return $ map (\f -> (f, diredEntries dState M.! R.fromString f)) fs diredUpDir :: YiM () diredUpDir = do dir <- currentDir diredDir $ takeDirectory dir diredCreateDir :: YiM () diredCreateDir = withMinibufferFree "Create Dir:" $ \nm -> do dir <- currentDir let newdir = dir T.unpack nm printMsg $ "Creating " <> T.pack newdir <> "..." io $ createDirectoryIfMissing True newdir diredRefresh -- | Elementary operations for dired file operations -- Map a dired mark operation (e.g. delete, rename, copy) command -- into a list of DiredOps, and use procDiredOp to execute them. -- Logic and implementation of each operation are packaged in procDiredOp -- See askDelFiles for example. -- If new elem op is added, just add corresponding procDiredOp to handle it. data DiredOp = DORemoveFile FilePath | DORemoveDir FilePath | DOCopyFile FilePath FilePath | DOCopyDir FilePath FilePath | DORename FilePath FilePath | DORemoveBuffer FilePath -- ^ remove the buffers that associate with the file | DOConfirm R.YiString [DiredOp] [DiredOp] -- ^ prompt a "yes/no" question. If yes, execute the -- first list of embedded DiredOps otherwise execute the -- second list of embedded DiredOps | DOCheck (IO Bool) [DiredOp] [DiredOp] -- ^ similar to DOConfirm, but no user interaction. Could -- be used to check file existence | DOCkOverwrite FilePath DiredOp -- ^ this is a shortcut, it invokes DCChoice if file exists | DOInput R.YiString (String -> [DiredOp]) -- ^ prompt a string and collect user input. -- the embedded list of DiredOps is generated based on input, -- Remember that the input should be checked with DOCheck | DOChoice R.YiString DiredOp -- ^ prompt a string, provide keybindings for 'y', 'n', -- '!', 'q' and optional 'h' (help) this is useful when -- overwriting of existing files is required to complete -- the op choice '!' will bypass following DOChoice -- prompts. | DOFeedback (DiredOpState -> YiM ()) -- ^ to feedback, given the state. such as show the result. | DONoOp -- ^ no operation yi-core-0.19.4/src/Yi/Editor.hs0000644000000000000000000007400107346545000014301 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Editor -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- The top level editor state, and operations on it. This is inside an -- internal module for easy re-export with Yi.Types bits. module Yi.Editor ( Editor(..), EditorM, MonadEditor(..) , runEditor , acceptedInputsOtherWindow , addJumpAtE , addJumpHereE , alternateBufferE , askConfigVariableA , bufferSet , buffersA , closeBufferAndWindowE , closeBufferE , closeOtherE , clrStatus , commonNamePrefix , currentBuffer , currentRegexA , currentWindowA , deleteBuffer , deleteTabE , doesBufferNameExist , emptyEditor , findBuffer , findBufferWith , findBufferWithName , findWindowWith , focusWindowE , getBufferStack , getBufferWithName , getBufferWithNameOrCurrent , getEditorDyn , getRegE , jumpBackE , jumpForwardE , killringA , layoutManagerNextVariantE , layoutManagerPreviousVariantE , layoutManagersNextE , layoutManagersPreviousE , layoutManagersPrintMsgE , maxStatusHeightA , moveTabE , moveWinNextE , moveWinPrevE , newBufferE , newEmptyBufferE , newTabE , newTempBufferE , newWindowE , nextTabE , nextWinE , onCloseActionsA , pendingEventsA , prevWinE , previousTabE , printMsg , printMsgs , printStatus , pushWinToFirstE , putEditorDyn , searchDirectionA , setDividerPosE , setRegE , setStatus , shiftOtherWindow , splitE , statusLine , statusLineInfo , statusLinesA , stringToNewBuffer , swapWinWithFirstE , switchToBufferE , switchToBufferWithNameE , tabsA , tryCloseE , windows , windowsA , windowsOnBufferE , withCurrentBuffer , withEveryBuffer , withGivenBuffer , withGivenBufferAndWindow , withOtherWindow , withWindowE ) where import Prelude hiding (all, concatMap, foldl, foldr) import Lens.Micro.Platform (Lens', lens, mapped, use, view, (%=), (%~), (&), (.~), (^.)) import Control.Monad (forM_, liftM, unless, when) import Control.Monad.Reader (MonadReader (ask), asks) import Control.Monad.State (gets, modify) import Data.Binary (Binary, get, put) import Data.Default (Default, def) import qualified Data.DelayList as DelayList (insert) import Data.DynamicState.Serializable (getDyn, putDyn) import Data.Foldable (Foldable (foldl, foldl', foldr), all, concatMap, toList) import Data.List (delete, (\\)) import Data.List.NonEmpty (NonEmpty (..), fromList, nub) import qualified Data.List.NonEmpty as NE (filter, head, length, toList, (<|)) import qualified Data.List.PointedList as PL (atEnd, moveTo) import qualified Data.List.PointedList.Circular as PL (PointedList (..), delete, deleteLeft, deleteOthers, deleteRight, focus, insertLeft, insertRight, length, next, previous, singleton, _focus) import qualified Data.Map as M (delete, elems, empty, insert, lookup, singleton, (!)) import Data.Maybe (fromJust, fromMaybe, isNothing) import qualified Data.Monoid as Mon ((<>)) import Data.Semigroup ((<>)) import qualified Data.Sequence as S import qualified Data.Text as T (Text, null, pack, unlines, unpack, unwords, isInfixOf) import System.FilePath (splitPath) import Yi.Buffer import Yi.Config import Yi.Interact as I (accepted, mkAutomaton) import Yi.JumpList (Jump (..), JumpList, addJump, jumpBack, jumpForward) import Yi.KillRing (krEmpty, krGet, krPut, krSet) import Yi.Layout import Yi.Monad (assign, getsAndModify, uses) import Yi.Rope (YiString, empty, fromText) import qualified Yi.Rope as R (YiString, fromText, snoc) import Yi.String (listify) import Yi.Style (defaultStyle) import Yi.Tab import Yi.Types import Yi.Utils import Yi.Window instance Binary Editor where put (Editor bss bs supply ts dv _sl msh kr regex _dir _ev _cwa ) = let putNE (x :| xs) = put x >> put xs in putNE bss >> put bs >> put supply >> put ts >> put dv >> put msh >> put kr >> put regex get = do bss <- (:|) <$> get <*> get bs <- get supply <- get ts <- get dv <- get msh <- get kr <- get regex <- get return $ emptyEditor { bufferStack = bss , buffers = bs , refSupply = supply , tabs_ = ts , dynamic = dv , maxStatusHeight = msh , killring = kr , currentRegex = regex } -- | The initial state emptyEditor :: Editor emptyEditor = Editor { buffers = M.singleton (bkey buf) buf , tabs_ = PL.singleton tab , bufferStack = bkey buf :| [] , refSupply = 3 , currentRegex = Nothing , searchDirection = Forward , dynamic = mempty , statusLines = DelayList.insert (maxBound, ([""], defaultStyle)) [] , killring = krEmpty , pendingEvents = [] , maxStatusHeight = 1 , onCloseActions = M.empty } where buf = newB 0 (MemBuffer "console") mempty win = (dummyWindow (bkey buf)) { wkey = WindowRef 1 , isMini = False } tab = makeTab1 2 win -- --------------------------------------------------------------------- makeLensesWithSuffix "A" ''Editor windows :: Editor -> PL.PointedList Window windows e = e ^. windowsA windowsA :: Lens' Editor (PL.PointedList Window) windowsA = currentTabA . tabWindowsA tabsA :: Lens' Editor (PL.PointedList Tab) tabsA = fixCurrentBufferA_ . tabs_A currentTabA :: Lens' Editor Tab currentTabA = tabsA . PL.focus askConfigVariableA :: (YiConfigVariable b, MonadEditor m) => m b askConfigVariableA = do cfg <- askCfg return $ cfg ^. configVariable -- --------------------------------------------------------------------- -- Buffer operations newRef :: MonadEditor m => m Int newRef = withEditor (refSupplyA %= (+ 1) >> use refSupplyA) newBufRef :: MonadEditor m => m BufferRef newBufRef = liftM BufferRef newRef -- | Create and fill a new buffer, using contents of string. -- | Does not focus the window, or make it the current window. -- | Call newWindowE or switchToBufferE to take care of that. stringToNewBuffer :: MonadEditor m => BufferId -- ^ The buffer indentifier -> YiString -- ^ The contents with which to populate -- the buffer -> m BufferRef stringToNewBuffer nm cs = withEditor $ do u <- newBufRef defRegStyle <- configRegionStyle <$> askCfg insertBuffer $ newB u nm cs m <- asks configFundamentalMode withGivenBuffer u $ do putRegionStyle defRegStyle setAnyMode m return u insertBuffer :: MonadEditor m => FBuffer -> m () insertBuffer b = withEditor . modify $ \e -> -- insert buffers at the end, so that -- "background" buffers do not interfere. e { bufferStack = nub (bufferStack e <> (bkey b :| [])) , buffers = M.insert (bkey b) b (buffers e)} -- Prevent possible space leaks in the editor structure forceFold1 :: Foldable t => t a -> t a forceFold1 x = foldr seq x x forceFoldTabs :: Foldable t => t Tab -> t Tab forceFoldTabs x = foldr (seq . forceTab) x x -- | Delete a buffer (and release resources associated with it). deleteBuffer :: MonadEditor m => BufferRef -> m () deleteBuffer k = withEditor $ do -- If the buffer has an associated close action execute that now. -- Unless the buffer is the last buffer in the editor. In which case -- it cannot be closed and, I think, the close action should not be -- applied. -- -- The close actions seem dangerous, but I know of no other simple -- way to resolve issues related to what buffer receives actions -- after the minibuffer closes. gets bufferStack >>= \case _ :| [] -> return () _ -> M.lookup k <$> gets onCloseActions >>= \m_action -> fromMaybe (return ()) m_action -- Now try deleting the buffer. Checking, once again, that it is not -- the last buffer. bs <- gets bufferStack ws <- use windowsA case bs of b0 :| nextB : _ -> do let pickOther w = if bufkey w == k then w {bufkey = other} else w visibleBuffers = bufkey <$> toList ws -- This ‘head’ always works because we witness that length of -- bs ≥ 2 (through case) and ‘delete’ only deletes up to 1 -- element so we at worst we end up with something like -- ‘head $ [] ++ [foo]’ when bs ≡ visibleBuffers bs' = NE.toList bs other = head $ (bs' \\ visibleBuffers) ++ delete k bs' when (b0 == k) $ -- we delete the currently selected buffer: the next buffer -- will become active in the main window, therefore it must be -- assigned a new window. switchToBufferE nextB -- NOTE: This *only* works if not all bufferStack buffers are -- equivalent to ‘k’. Assuring that there are no duplicates in -- the bufferStack is equivalent in this case because of its -- length. modify $ \e -> e & bufferStackA %~ fromList . forceFold1 . NE.filter (k /=) & buffersA %~ M.delete k & tabs_A %~ forceFoldTabs . fmap (mapWindows pickOther) -- all windows open on that buffer must switch to another -- buffer. windowsA . mapped . bufAccessListA %= forceFold1 . filter (k /=) _ -> return () -- Don't delete the last buffer. -- | Return the buffers we have, /in no particular order/ bufferSet :: Editor -> [FBuffer] bufferSet = M.elems . buffers -- | Return a prefix that can be removed from all buffer paths while -- keeping them unique. commonNamePrefix :: Editor -> [FilePath] commonNamePrefix = commonPrefix . fmap (dropLast . splitPath) . fbufs . fmap (^. identA) . bufferSet where dropLast [] = [] dropLast x = init x fbufs xs = [ x | FileBuffer x <- xs ] -- drop the last component, so that it is never hidden. getBufferStack :: MonadEditor m => m (NonEmpty FBuffer) getBufferStack = withEditor $ do bufMap <- gets buffers gets $ fmap (bufMap M.!) . bufferStack findBuffer :: MonadEditor m => BufferRef -> m (Maybe FBuffer) findBuffer k = withEditor (gets (M.lookup k . buffers)) -- | Find buffer with this key findBufferWith :: BufferRef -> Editor -> FBuffer findBufferWith k e = case M.lookup k (buffers e) of Just x -> x Nothing -> error "Editor.findBufferWith: no buffer has this key" -- | Find buffers with this name findBufferWithName :: T.Text -> Editor -> [BufferRef] findBufferWithName n e = let bufs = M.elems $ buffers e hasInfix b = n `T.isInfixOf` identString b in map bkey $ filter hasInfix bufs doesBufferNameExist :: T.Text -> Editor -> Bool doesBufferNameExist n e = not $ null $ filter ((== n) . identString) $ M.elems $ buffers e -- | Find buffer with given name. Fail if not found. getBufferWithName :: MonadEditor m => T.Text -> m BufferRef getBufferWithName bufName = withEditor $ do bs <- gets $ findBufferWithName bufName case bs of [] -> fail ("Buffer not found: " ++ T.unpack bufName) [b] -> return b _ -> fail ("Ambiguous buffer name: " ++ T.unpack bufName) ------------------------------------------------------------------------ -- | Perform action with any given buffer, using the last window that -- was used for that buffer. withGivenBuffer :: MonadEditor m => BufferRef -> BufferM a -> m a withGivenBuffer k f = do b <- gets (findBufferWith k) withGivenBufferAndWindow (b ^. lastActiveWindowA) k f -- | Perform action with any given buffer withGivenBufferAndWindow :: MonadEditor m => Window -> BufferRef -> BufferM a -> m a withGivenBufferAndWindow w k f = withEditor $ do accum <- asks configKillringAccumulate let edit e = let b = findBufferWith k e (v, us, b') = runBufferFull w b f in (e & buffersA .~ mapAdjust' (const b') k (buffers e) & killringA %~ (\kr -> if accum && all updateIsDelete us then let putDelKr kr' (Delete _ dir s) = krPut dir s kr' putDelKr kr' _ = kr' in foldl' putDelKr kr (S.reverse us) else kr) , (us, v)) (us, v) <- getsAndModify edit updHandler <- return . bufferUpdateHandler =<< ask unless (S.null us || S.null updHandler) $ forM_ updHandler (\h -> withGivenBufferAndWindow w k (h us)) return v -- | Perform action with current window's buffer withCurrentBuffer :: MonadEditor m => BufferM a -> m a withCurrentBuffer f = withEditor $ do w <- use currentWindowA withGivenBufferAndWindow w (bufkey w) f withEveryBuffer :: MonadEditor m => BufferM a -> m [a] withEveryBuffer action = withEditor (gets bufferStack) >>= mapM (`withGivenBuffer` action) . NE.toList currentWindowA :: Lens' Editor Window currentWindowA = windowsA . PL.focus -- | Return the current buffer currentBuffer :: Editor -> BufferRef currentBuffer = NE.head . bufferStack ----------------------- -- Handling of status -- | Prints a message with 'defaultStyle'. printMsg :: MonadEditor m => T.Text -> m () printMsg s = printStatus ([s], defaultStyle) -- | Prints a all given messages with 'defaultStyle'. printMsgs :: MonadEditor m => [T.Text] -> m () printMsgs s = printStatus (s, defaultStyle) printStatus :: MonadEditor m => Status -> m () printStatus = setTmpStatus 1 -- | Set the "background" status line setStatus :: MonadEditor m => Status -> m () setStatus = setTmpStatus maxBound -- | Clear the status line clrStatus :: EditorM () clrStatus = setStatus ([""], defaultStyle) statusLine :: Editor -> [T.Text] statusLine = fst . statusLineInfo statusLineInfo :: Editor -> Status statusLineInfo = snd . head . statusLines setTmpStatus :: MonadEditor m => Int -> Status -> m () setTmpStatus delay s = withEditor $ do statusLinesA %= DelayList.insert (delay, s) -- also show in the messages buffer, so we don't loose any message bs <- gets (filter ((== MemBuffer "messages") . view identA) . M.elems . buffers) b <- case bs of (b':_) -> return $ bkey b' [] -> stringToNewBuffer (MemBuffer "messages") mempty let m = listify $ R.fromText <$> fst s withGivenBuffer b $ botB >> insertN (m `R.snoc` '\n') -- --------------------------------------------------------------------- -- kill-register (vim-style) interface to killring. -- -- Note that our vim keymap currently has its own registers -- and doesn't use killring. -- | Put string into yank register setRegE :: R.YiString -> EditorM () setRegE s = killringA %= krSet s -- | Return the contents of the yank register getRegE :: EditorM R.YiString getRegE = uses killringA krGet -- --------------------------------------------------------------------- -- | Dynamically-extensible state components. -- -- These hooks are used by keymaps to store values that result from -- Actions (i.e. that result from IO), as opposed to the pure values -- they generate themselves, and can be stored internally. -- -- The `dynamic' field is a type-indexed map. -- -- | Retrieve a value from the extensible state getEditorDyn :: (MonadEditor m, YiVariable a, Default a, Functor m) => m a getEditorDyn = fromMaybe def <$> getDyn (use dynamicA) (assign dynamicA) -- | Insert a value into the extensible state, keyed by its type putEditorDyn :: (MonadEditor m, YiVariable a, Functor m) => a -> m () putEditorDyn = putDyn (use dynamicA) (assign dynamicA) -- | Like fnewE, create a new buffer filled with the String @s@, -- Switch the current window to this buffer. Doesn't associate any -- file with the buffer (unlike fnewE) and so is good for popup -- internal buffers (like scratch) newBufferE :: BufferId -- ^ buffer name -> YiString -- ^ buffer contents -> EditorM BufferRef newBufferE f s = do b <- stringToNewBuffer f s switchToBufferE b return b -- | Like 'newBufferE' but defaults to empty contents. newEmptyBufferE :: BufferId -> EditorM BufferRef newEmptyBufferE f = newBufferE f Yi.Rope.empty alternateBufferE :: Int -> EditorM () alternateBufferE n = do Window { bufAccessList = lst } <- use currentWindowA if null lst || (length lst - 1) < n then fail "no alternate buffer" else switchToBufferE $ lst!!n -- | Create a new zero size window on a given buffer newZeroSizeWindow :: Bool -> BufferRef -> WindowRef -> Window newZeroSizeWindow mini bk ref = Window mini bk [] 0 0 emptyRegion ref 0 Nothing -- | Create a new window onto the given buffer. newWindowE :: Bool -> BufferRef -> EditorM Window newWindowE mini bk = newZeroSizeWindow mini bk . WindowRef <$> newRef -- | Attach the specified buffer to the current window switchToBufferE :: BufferRef -> EditorM () switchToBufferE bk = windowsA . PL.focus %= \w -> w & bufkeyA .~ bk & bufAccessListA %~ forceFold1 . (bufkey w:) . filter (bk /=) -- | Switch to the buffer specified as parameter. If the buffer name -- is empty, switch to the next buffer. switchToBufferWithNameE :: T.Text -> EditorM () switchToBufferWithNameE "" = alternateBufferE 0 switchToBufferWithNameE bufName = switchToBufferE =<< getBufferWithName bufName -- | Close a buffer. -- Note: close the current buffer if the empty string is given closeBufferE :: T.Text -> EditorM () closeBufferE nm = deleteBuffer =<< getBufferWithNameOrCurrent nm getBufferWithNameOrCurrent :: MonadEditor m => T.Text -> m BufferRef getBufferWithNameOrCurrent t = withEditor $ case T.null t of True -> gets currentBuffer False -> getBufferWithName t ------------------------------------------------------------------------ -- | Close current buffer and window, unless it's the last one. closeBufferAndWindowE :: EditorM () closeBufferAndWindowE = do -- Fetch the current buffer *before* closing the window. -- The tryCloseE, since it uses tabsA, will have the -- current buffer "fixed" to the buffer of the window that is -- brought into focus. If the current buffer is accessed after the -- tryCloseE then the current buffer may not be the same as the -- buffer before tryCloseE. This would be bad. b <- gets currentBuffer tryCloseE deleteBuffer b -- | Rotate focus to the next window nextWinE :: EditorM () nextWinE = windowsA %= PL.next -- | Rotate focus to the previous window prevWinE :: EditorM () prevWinE = windowsA %= PL.previous -- | Swaps the focused window with the first window. Useful for -- layouts such as 'HPairOneStack', for which the first window is the -- largest. swapWinWithFirstE :: EditorM () swapWinWithFirstE = windowsA %= swapFocus (fromJust . PL.moveTo 0) -- | Moves the focused window to the first window, and moves all other -- windows down the stack. pushWinToFirstE :: EditorM () pushWinToFirstE = windowsA %= pushToFirst where pushToFirst ws = case PL.delete ws of Nothing -> ws Just ws' -> PL.insertLeft (ws ^. PL.focus) (fromJust $ PL.moveTo 0 ws') -- | Swap focused window with the next one moveWinNextE :: EditorM () moveWinNextE = windowsA %= swapFocus PL.next -- | Swap focused window with the previous one moveWinPrevE :: EditorM () moveWinPrevE = windowsA %= swapFocus PL.previous -- | A "fake" accessor that fixes the current buffer after a change of -- the current window. -- -- Enforces invariant that top of buffer stack is the buffer of the -- current window. fixCurrentBufferA_ :: Lens' Editor Editor fixCurrentBufferA_ = lens id (\_old new -> let ws = windows new b = findBufferWith (bufkey $ PL._focus ws) new newBufferStack = nub (bkey b NE.<| bufferStack new) -- make sure we do not hold to old versions by seqing the length. in NE.length newBufferStack `seq` new & bufferStackA .~ newBufferStack) withWindowE :: Window -> BufferM a -> EditorM a withWindowE w = withGivenBufferAndWindow w (bufkey w) findWindowWith :: WindowRef -> Editor -> Window findWindowWith k e = head $ concatMap (\win -> [win | wkey win == k]) $ windows e -- | Return the windows that are currently open on the buffer whose -- key is given windowsOnBufferE :: BufferRef -> EditorM [Window] windowsOnBufferE k = do ts <- use tabsA let tabBufEq = concatMap (\win -> [win | bufkey win == k]) . (^. tabWindowsA) return $ concatMap tabBufEq ts -- | bring the editor focus the window with the given key. -- -- Fails if no window with the given key is found. focusWindowE :: WindowRef -> EditorM () focusWindowE k = do -- Find the tab index and window index ts <- use tabsA let check (False, i) win = if wkey win == k then (True, i) else (False, i + 1) check r@(True, _) _win = r searchWindowSet (False, tabIndex, _) ws = case foldl check (False, 0) (ws ^. tabWindowsA) of (True, winIndex) -> (True, tabIndex, winIndex) (False, _) -> (False, tabIndex + 1, 0) searchWindowSet r@(True, _, _) _ws = r case foldl searchWindowSet (False, 0, 0) ts of (False, _, _) -> fail $ "No window with key " ++ show k ++ "found. (focusWindowE)" (True, tabIndex, winIndex) -> do assign tabsA (fromJust $ PL.moveTo tabIndex ts) windowsA %= fromJust . PL.moveTo winIndex -- | Split the current window, opening a second window onto current buffer. -- TODO: unfold newWindowE here? splitE :: EditorM () splitE = do w <- gets currentBuffer >>= newWindowE False windowsA %= PL.insertRight w -- | Prints the description of the current layout manager in the status bar layoutManagersPrintMsgE :: EditorM () layoutManagersPrintMsgE = do lm <- use $ currentTabA . tabLayoutManagerA printMsg . T.pack $ describeLayout lm -- | Cycle to the next layout manager, or the first one if the current -- one is nonstandard. layoutManagersNextE :: EditorM () layoutManagersNextE = withLMStackE PL.next >> layoutManagersPrintMsgE -- | Cycle to the previous layout manager, or the first one if the -- current one is nonstandard. layoutManagersPreviousE :: EditorM () layoutManagersPreviousE = withLMStackE PL.previous >> layoutManagersPrintMsgE -- | Helper function for 'layoutManagersNext' and 'layoutManagersPrevious' withLMStackE :: (PL.PointedList AnyLayoutManager -> PL.PointedList AnyLayoutManager) -> EditorM () withLMStackE f = askCfg >>= \cfg -> currentTabA . tabLayoutManagerA %= go (layoutManagers cfg) where go [] lm = lm go lms lm = case findPL (layoutManagerSameType lm) lms of Nothing -> head lms Just lmsPL -> f lmsPL ^. PL.focus -- | Next variant of the current layout manager, as given by 'nextVariant' layoutManagerNextVariantE :: EditorM () layoutManagerNextVariantE = do currentTabA . tabLayoutManagerA %= nextVariant layoutManagersPrintMsgE -- | Previous variant of the current layout manager, as given by -- 'previousVariant' layoutManagerPreviousVariantE :: EditorM () layoutManagerPreviousVariantE = do currentTabA . tabLayoutManagerA %= previousVariant layoutManagersPrintMsgE -- | Sets the given divider position on the current tab setDividerPosE :: DividerRef -> DividerPosition -> EditorM () setDividerPosE ref = assign (currentTabA . tabDividerPositionA ref) -- | Creates a new tab containing a window that views the current buffer. newTabE :: EditorM () newTabE = do bk <- gets currentBuffer win <- newWindowE False bk ref <- newRef tabsA %= PL.insertRight (makeTab1 ref win) -- | Moves to the next tab in the round robin set of tabs nextTabE :: EditorM () nextTabE = tabsA %= PL.next -- | Moves to the previous tab in the round robin set of tabs previousTabE :: EditorM () previousTabE = tabsA %= PL.previous -- | Moves the focused tab to the given index, or to the end if the -- index is not specified. moveTabE :: Maybe Int -> EditorM () moveTabE Nothing = do count <- uses tabsA PL.length tabsA %= fromJust . PL.moveTo (pred count) moveTabE (Just n) = do newTabs <- uses tabsA (PL.moveTo n) when (isNothing newTabs) failure assign tabsA $ fromJust newTabs where failure = fail $ "moveTab " ++ show n ++ ": no such tab" -- | Deletes the current tab. If there is only one tab open then error out. -- When the last tab is focused, move focus to the left, otherwise -- move focus to the right. deleteTabE :: EditorM () deleteTabE = tabsA %= fromMaybe failure . deleteTab where failure = error "deleteTab: cannot delete sole tab" deleteTab tabs = if PL.atEnd tabs then PL.deleteLeft tabs else PL.deleteRight tabs -- | Close the current window. If there is only one tab open and the tab -- contains only one window then do nothing. tryCloseE :: EditorM () tryCloseE = do ntabs <- uses tabsA PL.length nwins <- uses windowsA PL.length unless (ntabs == 1 && nwins == 1) $ if nwins == 1 -- Could the Maybe response from deleteLeft be used instead of the -- def 'if'? then tabsA %= fromJust . PL.deleteLeft else windowsA %= fromJust . PL.deleteLeft -- | Make the current window the only window on the screen closeOtherE :: EditorM () closeOtherE = windowsA %= PL.deleteOthers -- | Switch focus to some other window. If none is available, create one. shiftOtherWindow :: MonadEditor m => m () shiftOtherWindow = withEditor $ do len <- uses windowsA PL.length if len == 1 then splitE else nextWinE -- | Execute the argument in the context of an other window. Create -- one if necessary. The current window is re-focused after the -- argument has completed. withOtherWindow :: MonadEditor m => m a -> m a withOtherWindow f = do shiftOtherWindow x <- f withEditor prevWinE return x acceptedInputs :: EditorM [T.Text] acceptedInputs = do km <- defaultKm <$> askCfg keymap <- withCurrentBuffer $ gets (withMode0 modeKeymap) let l = I.accepted 3 . I.mkAutomaton . extractTopKeymap . keymap $ km return $ fmap T.unwords l -- | Shows the current key bindings in a new window acceptedInputsOtherWindow :: EditorM () acceptedInputsOtherWindow = do ai <- acceptedInputs b <- stringToNewBuffer (MemBuffer "keybindings") (fromText $ T.unlines ai) w <- newWindowE False b windowsA %= PL.insertRight w addJumpHereE :: EditorM () addJumpHereE = addJumpAtE =<< withCurrentBuffer pointB addJumpAtE :: Point -> EditorM () addJumpAtE point = do w <- use currentWindowA shouldAddJump <- case jumpList w of Just (PL.PointedList _ (Jump mark bf) _) -> do bfStillAlive <- gets (M.lookup bf . buffers) case bfStillAlive of Nothing -> return False _ -> do p <- withGivenBuffer bf . use $ markPointA mark return $! (p, bf) /= (point, bufkey w) _ -> return True when shouldAddJump $ do m <- withCurrentBuffer setMarkHereB let bf = bufkey w j = Jump m bf assign currentWindowA $ w & jumpListA %~ addJump j return () jumpBackE :: EditorM () jumpBackE = addJumpHereE >> modifyJumpListE jumpBack jumpForwardE :: EditorM () jumpForwardE = modifyJumpListE jumpForward modifyJumpListE :: (JumpList -> JumpList) -> EditorM () modifyJumpListE f = do w <- use currentWindowA case f $ w ^. jumpListA of Nothing -> return () Just (PL.PointedList _ (Jump mark bf) _) -> do switchToBufferE bf withCurrentBuffer $ use (markPointA mark) >>= moveTo currentWindowA . jumpListA %= f -- | Creates an in-memory buffer with a unique name. newTempBufferE :: EditorM BufferRef newTempBufferE = do e <- gets id -- increment the index of the hint until no buffer is found with that name let find_next currentName (nextName:otherNames) = if doesBufferNameExist currentName e then find_next nextName otherNames else currentName find_next _ [] = error "Looks like nearly infinite list has just ended." next_tmp_name = find_next name names (name : names) = (fmap (("tmp-" Mon.<>) . T.pack . show) [0 :: Int ..]) newEmptyBufferE (MemBuffer next_tmp_name) yi-core-0.19.4/src/Yi/Eval.hs0000644000000000000000000003276407346545000013754 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} #ifdef HINT {-# LANGUAGE FlexibleContexts #-} #endif {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Eval -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Evaluator for actions ('Action', 'YiAction'). Uses a @GHCi@ session -- under the hood. module Yi.Eval ( -- * Main (generic) evaluation interface execEditorAction, getAllNamesInScope, describeNamedAction, Evaluator(..), evaluator, -- ** Standard evaluators #ifdef HINT ghciEvaluator, #endif publishedActionsEvaluator, publishedActions, publishAction, -- * Eval/Interpretation jumpToErrorE, jumpToE, consoleKeymap ) where import Prelude hiding (mapM_) import Lens.Micro.Platform ( (^.), (.=), (%=) ) import Control.Monad (when, forever, void) import Data.Array ( elems ) import Data.Binary ( Binary ) import Data.Default ( Default, def ) import Data.Foldable ( mapM_ ) import qualified Data.HashMap.Strict as M ( HashMap, insert, lookup, empty, keys ) import Data.Monoid ((<>)) import Data.Semigroup ( Semigroup ) import Data.Typeable ( Typeable ) #ifdef HINT import Control.Concurrent ( takeMVar, putMVar, newEmptyMVar, MVar, forkIO ) import Control.Monad.Base ( MonadBase ) import Control.Monad.Catch ( try ) import Control.Monad.Trans ( lift ) import Data.Binary ( get, put ) import Data.List ( sort ) import qualified Language.Haskell.Interpreter as LHI ( typeOf, setImportsQ, searchPath, set, runInterpreter, ModuleElem(Data, Class, Fun), getModuleExports, as, loadModules, languageExtensions, OptionVal((:=)), InterpreterError, Extension(OverloadedStrings), setTopLevelModules, InterpreterT, interpret ) import System.Directory ( doesFileExist ) import Yi.Core ( errorEditor ) import Yi.Editor ( getEditorDyn, putEditorDyn, MonadEditor) import qualified Yi.Paths ( getEvaluatorContextFilename ) import Yi.String ( showT ) import Yi.Utils ( io ) #endif import Text.Read ( readMaybe ) import Yi.Buffer ( gotoLn, moveXorEol, BufferM, readLnB, pointB, botB, insertN, getBookmarkB, markPointA ) import Yi.Config.Simple.Types ( customVariable, Field, ConfigM ) import Yi.Core ( runAction ) import Yi.Types ( YiVariable, YiConfigVariable ) import Yi.Editor ( printMsg, askCfg, withCurrentBuffer, withCurrentBuffer ) import Yi.File ( openingNewFile ) import Yi.Hooks ( runHook ) import Yi.Keymap ( YiM, Action, YiAction, makeAction, Keymap, write ) import Yi.Keymap.Keys ( event, Event(..), Key(KEnter) ) import Yi.Regex ( Regex, makeRegex, matchOnceText ) import qualified Yi.Rope as R ( toString, YiString, splitAt, length ) import Yi.Utils ( makeLensesWithSuffix ) infixl 1 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b a <&> f = f <$> a -- TODO: should we be sticking Text here? -- | Config variable for customising the behaviour of -- 'execEditorAction' and 'getAllNamesInScope'. -- -- Set this variable using 'evaluator'. See 'ghciEvaluator' and -- 'finiteListEvaluator' for two implementation. data Evaluator = Evaluator { execEditorActionImpl :: String -> YiM () -- ^ implementation of 'execEditorAction' , getAllNamesInScopeImpl :: YiM [String] -- ^ implementation of 'getAllNamesInScope' , describeNamedActionImpl :: String -> YiM String -- ^ describe named action (or at least its type.), simplest implementation is at least @return@. } deriving (Typeable) -- * Evaluator based on GHCi -- | Cached variable for getAllNamesInScopeImpl newtype NamesCache = NamesCache [String] deriving (Typeable, Binary) instance Default NamesCache where def = NamesCache [] instance YiVariable NamesCache -- | Cached dictionary for describeNameImpl newtype HelpCache = HelpCache (M.HashMap String String) deriving (Typeable, Binary) instance Default HelpCache where def = HelpCache M.empty instance YiVariable HelpCache #ifdef HINT data HintRequest = HintEvaluate String (MVar (Either LHI.InterpreterError Action)) | HintGetNames (MVar (Either LHI.InterpreterError [LHI.ModuleElem])) | HintDescribe String (MVar (Either LHI.InterpreterError String)) newtype HintThreadVar = HintThreadVar (Maybe (MVar HintRequest)) deriving (Typeable, Default) instance Binary HintThreadVar where put _ = return () get = return def instance YiVariable HintThreadVar getHintThread :: (MonadEditor m, MonadBase IO m) => m (MVar HintRequest) getHintThread = do HintThreadVar x <- getEditorDyn case x of Just t -> return t Nothing -> do req <- io newEmptyMVar contextFile <- Yi.Paths.getEvaluatorContextFilename void . io . forkIO $ hintEvaluatorThread req contextFile putEditorDyn . HintThreadVar $ Just req return req hintEvaluatorThread :: MVar HintRequest -> FilePath -> IO () hintEvaluatorThread request contextFile = do haveUserContext <- doesFileExist contextFile void $ LHI.runInterpreter $ do LHI.set [LHI.searchPath LHI.:= []] LHI.set [LHI.languageExtensions LHI.:= [ LHI.OverloadedStrings ]] when haveUserContext $ do LHI.loadModules [contextFile] LHI.setTopLevelModules ["Env"] -- Yi.Keymap: Action lives there setImp <- try $ LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")] :: LHI.InterpreterT IO (Either LHI.InterpreterError ()) case setImp of Left e -> lift $ forever $ takeMVar request >>= \case HintEvaluate _ response -> putMVar response (Left e) HintGetNames response -> putMVar response (Left e) HintDescribe _ response -> putMVar response (Left e) Right _ -> forever $ lift (takeMVar request) >>= \case HintEvaluate s response -> do res <- try $ LHI.interpret ("Yi.makeAction (" ++ s ++ ")") (LHI.as :: Action) lift $ putMVar response res HintGetNames response -> do res <- try $ LHI.getModuleExports "Yi" lift $ putMVar response res HintDescribe name response -> do res <- try $ LHI.typeOf name lift $ putMVar response res -- Evaluator implemented by calling GHCi. This evaluator can run -- arbitrary expressions in the class 'YiAction'. -- -- The following two imports are always present: -- -- > import Yi -- > import qualified Yi.Keymap as Yi.Keymap -- -- Also, if the file -- -- > $HOME/.config/yi/local/Env.hs -- -- exists, it is imported unqualified. ghciEvaluator :: Evaluator ghciEvaluator = Evaluator { execEditorActionImpl = execAction , getAllNamesInScopeImpl = getNames , describeNamedActionImpl = describeName -- TODO: use haddock to add docs } where execAction :: String -> YiM () execAction s = do request <- getHintThread res <- io $ do response <- newEmptyMVar putMVar request (HintEvaluate s response) takeMVar response case res of Left err -> errorEditor (showT err) Right action -> runAction action getNames :: YiM [String] getNames = do NamesCache cache <- getEditorDyn result <- if null cache then do request <- getHintThread res <- io $ do response <- newEmptyMVar putMVar request (HintGetNames response) takeMVar response return $ case res of Left err -> [show err] Right exports -> flattenExports exports else return $ sort cache putEditorDyn $ NamesCache result return result flattenExports :: [LHI.ModuleElem] -> [String] flattenExports = concatMap flattenExport flattenExport :: LHI.ModuleElem -> [String] flattenExport (LHI.Fun x) = [x] flattenExport (LHI.Class _ xs) = xs flattenExport (LHI.Data _ xs) = xs describeName :: String -> YiM String describeName name = do HelpCache cache <- getEditorDyn description <- case name `M.lookup` cache of Nothing -> do request <- getHintThread res <- io $ do response <- newEmptyMVar putMVar request (HintDescribe name response) takeMVar response let newDescription = either show id res putEditorDyn $ HelpCache $ M.insert name newDescription cache return newDescription Just description -> return description return $ name ++ " :: " ++ description #endif -- * 'PublishedActions' evaluator newtype PublishedActions = PublishedActions { _publishedActions :: M.HashMap String Action } deriving(Typeable, Semigroup, Monoid) instance Default PublishedActions where def = mempty makeLensesWithSuffix "A" ''PublishedActions instance YiConfigVariable PublishedActions -- | Accessor for the published actions. Consider using -- 'publishAction'. publishedActions :: Field (M.HashMap String Action) publishedActions = customVariable . _publishedActionsA -- | Publish the given action, by the given name. This will overwrite -- any existing actions by the same name. publishAction :: (YiAction a x, Show x) => String -> a -> ConfigM () publishAction s a = publishedActions %= M.insert s (makeAction a) -- | Evaluator based on a fixed list of published actions. Has a few -- differences from 'ghciEvaluator': -- -- * expressions can't be evaluated -- -- * all suggested actions are actually valued -- -- * (related to the above) doesn't contain junk actions from Prelude -- -- * doesn't require GHCi backend, so uses less memory publishedActionsEvaluator :: Evaluator publishedActionsEvaluator = Evaluator { getAllNamesInScopeImpl = askCfg <&> M.keys . (^. publishedActions) , execEditorActionImpl = \s -> askCfg <&> M.lookup s . (^. publishedActions) >>= mapM_ runAction , describeNamedActionImpl = return -- TODO: try to show types using TemplateHaskell! } -- * Miscellaneous interpreter -- | Jumps to specified position in a given file. jumpToE :: FilePath -- ^ Filename to make the jump in. -> Int -- ^ Line to jump to. -> Int -- ^ Column to jump to. -> YiM () jumpToE filename line column = openingNewFile filename $ gotoLn line >> moveXorEol column -- | Regex parsing the error message format. errorRegex :: Regex errorRegex = makeRegex ("^(.+):([0-9]+):([0-9]+):.*$" :: String) -- | Parses an error message. Fails if it can't parse out the needed -- information, namely filename, line number and column number. parseErrorMessage :: R.YiString -> Maybe (String, Int, Int) parseErrorMessage ln = do (_ ,result, _) <- matchOnceText errorRegex (R.toString ln) case take 3 $ map fst $ elems result of [_, fname, l, c] -> (,,) <$> return fname <*> readMaybe l <*> readMaybe c _ -> Nothing -- | Tries to parse an error message at current line using -- 'parseErrorMessage'. parseErrorMessageB :: BufferM (Maybe (String, Int, Int)) parseErrorMessageB = parseErrorMessage <$> readLnB -- | Tries to jump to error at the current line. See -- 'parseErrorMessageB'. jumpToErrorE :: YiM () jumpToErrorE = withCurrentBuffer parseErrorMessageB >>= \case Nothing -> printMsg "Couldn't parse out an error message." Just (f, l, c) -> jumpToE f l c prompt :: R.YiString prompt = "Yi> " -- | Tries to strip the 'prompt' from the front of the given 'String'. -- If the prompt is not found, returns the input command as-is. takeCommand :: R.YiString -> R.YiString takeCommand t = case R.splitAt (R.length prompt) t of (f, s) -> if f == prompt then s else t consoleKeymap :: Keymap consoleKeymap = do _ <- event (Event KEnter []) write $ withCurrentBuffer readLnB >>= \x -> case parseErrorMessage x of Just (f,l,c) -> jumpToE f l c Nothing -> do withCurrentBuffer $ do p <- pointB botB p' <- pointB when (p /= p') $ insertN ("\n" <> prompt <> takeCommand x) insertN "\n" pt <- pointB insertN prompt bm <- getBookmarkB "errorInsert" markPointA bm .= pt execEditorAction . R.toString $ takeCommand x instance Default Evaluator where #ifdef HINT def = ghciEvaluator #else def = publishedActionsEvaluator #endif instance YiConfigVariable Evaluator -- | Runs the action, as written by the user. -- -- The behaviour of this function can be customised by modifying the -- 'Evaluator' variable. execEditorAction :: String -> YiM () execEditorAction = runHook execEditorActionImpl -- | Lists the action names in scope, for use by 'execEditorAction', -- and 'help' index. -- -- The behaviour of this function can be customised by modifying the -- 'Evaluator' variable. getAllNamesInScope :: YiM [String] getAllNamesInScope = runHook getAllNamesInScopeImpl -- | Describes the named action in scope, for use by 'help'. -- -- The behaviour of this function can be customised by modifying the -- 'Evaluator' variable. describeNamedAction :: String -> YiM String describeNamedAction = runHook describeNamedActionImpl -- | The evaluator to use for 'execEditorAction' and -- 'getAllNamesInScope'. evaluator :: Field Evaluator evaluator = customVariable yi-core-0.19.4/src/Yi/Event.hs0000644000000000000000000000364207346545000014137 0ustar0000000000000000module Yi.Event ( Event(..), prettyEvent, Key(..), Modifier(..), -- * Key codes eventToChar ) where import Data.Bits (setBit) import Data.Char (chr, ord) data Modifier = MShift | MCtrl | MMeta | MSuper | MHyper deriving (Show,Eq,Ord) data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu | KLeft | KDown | KRight | KEnter | KTab deriving (Eq,Show,Ord) data Event = Event Key [Modifier] deriving (Eq) instance Ord Event where compare (Event k1 m1) (Event k2 m2) = compare m1 m2 `mappend` compare k1 k2 -- so, all Ctrl+char, meta+char, etc. all form a continuous range instance Show Event where show = prettyEvent prettyEvent :: Event -> String prettyEvent (Event k mods) = concatMap ((++ "-") . prettyModifier) mods ++ prettyKey k where prettyKey (KFun i) = 'F' : show i prettyKey (KASCII c) = [c] prettyKey key = tail $ show key prettyModifier m = [ show m !! 1] -- | Map an Event to a Char. This is used in the emacs keymap for Ctrl-Q and vim keymap 'insertSpecialChar' eventToChar :: Event -> Char eventToChar (Event KEnter _) = '\CR' eventToChar (Event KEsc _) = '\ESC' eventToChar (Event KBS _) = '\127' eventToChar (Event KTab _) = '\t' eventToChar (Event (KASCII c) mods) = (if MMeta `elem` mods then setMeta else id) $ (if MCtrl `elem` mods then ctrlLowcase else id) c eventToChar _ev = '?' remapChar :: Char -> Char -> Char -> Char -> Char -> Char remapChar a1 b1 a2 _ c | a1 <= c && c <= b1 = chr $ ord c - ord a1 + ord a2 | otherwise = c ctrlLowcase :: Char -> Char ctrlLowcase = remapChar 'a' 'z' '\^A' '\^Z' -- set the meta bit, as if Mod1/Alt had been pressed setMeta :: Char -> Char setMeta c = chr (setBit (ord c) metaBit) metaBit :: Int metaBit = 7 yi-core-0.19.4/src/Yi/File.hs0000644000000000000000000001454407346545000013740 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.File -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable module Yi.File ( -- * File-based actions editFile, openingNewFile, openNewFile, viWrite, viWriteTo, viSafeWriteTo, fwriteE, fwriteBufferE, fwriteAllY, fwriteToE, backupE, revertE, -- * Helper functions setFileName, deservesSave, -- * Configuration preSaveHooks ) where import Lens.Micro.Platform ((.=), makeLenses, use, view, (^.)) import Control.Monad (filterM, void, when) import Control.Monad.Base (liftBase) import Data.Default (Default, def) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, append, cons, pack, unpack) import Data.Time (getCurrentTime) import Data.Typeable (Typeable) import System.Directory (doesDirectoryExist, doesFileExist) import System.FriendlyPath (userToCanonPath) import Yi.Buffer import Yi.Config.Simple.Types (Field, customVariable) import Yi.Core (errorEditor, runAction) import Yi.Dired (editFile) import Yi.Editor import Yi.Keymap () import Yi.Monad (gets) import qualified Yi.Rope as R (readFile, writeFile) import Yi.String (showT) import Yi.Types import Yi.Utils (io) newtype PreSaveHooks = PreSaveHooks { _unPreSaveHooks :: [Action] } deriving Typeable instance Default PreSaveHooks where def = PreSaveHooks [] instance YiConfigVariable PreSaveHooks makeLenses ''PreSaveHooks preSaveHooks :: Field [Action] preSaveHooks = customVariable . unPreSaveHooks -- | Tries to open a new buffer with 'editFile' and runs the given -- action on the buffer handle if it succeeds. -- -- If the 'editFile' fails, just the failure message is printed. openingNewFile :: FilePath -> BufferM a -> YiM () openingNewFile fp act = editFile fp >>= \case Left m -> printMsg m Right ref -> void $ withGivenBuffer ref act -- | Same as @openingNewFile@ with no action to run after. openNewFile :: FilePath -> YiM () openNewFile = flip openingNewFile $ return () -- | Revert to the contents of the file on disk revertE :: YiM () revertE = withCurrentBuffer (gets file) >>= \case Just fp -> do now <- io getCurrentTime rf <- liftBase $ R.readFile fp >>= \case Left m -> print ("Can't revert: " <> m) >> return Nothing Right c -> return $ Just c case rf of Nothing -> return () Just s -> do withCurrentBuffer $ revertB s now printMsg ("Reverted from " <> showT fp) Nothing -> printMsg "Can't revert, no file associated with buffer." -- | Try to write a file in the manner of vi/vim -- Need to catch any exception to avoid losing bindings viWrite :: YiM () viWrite = withCurrentBuffer (gets file) >>= \case Nothing -> errorEditor "no file name associated with buffer" Just f -> do bufInfo <- withCurrentBuffer bufInfoB let s = bufInfoFileName bufInfo succeed <- fwriteE let message = (showT f <>) (if f == s then " written" else " " <> showT s <> " written") when succeed $ printMsg message -- | Try to write to a named file in the manner of vi/vim viWriteTo :: T.Text -> YiM () viWriteTo f = do bufInfo <- withCurrentBuffer bufInfoB let s = T.pack $ bufInfoFileName bufInfo succeed <- fwriteToE f let message = f `T.append` if f == s then " written" else ' ' `T.cons` s `T.append` " written" when succeed $ printMsg message -- | Try to write to a named file if it doesn't exist. Error out if it does. viSafeWriteTo :: T.Text -> YiM () viSafeWriteTo f = do existsF <- liftBase $ doesFileExist (T.unpack f) if existsF then errorEditor $ f <> ": File exists (add '!' to override)" else viWriteTo f -- | Write current buffer to disk, if this buffer is associated with a file fwriteE :: YiM Bool fwriteE = fwriteBufferE =<< gets currentBuffer -- | Write a given buffer to disk if it is associated with a file. fwriteBufferE :: BufferRef -> YiM Bool fwriteBufferE bufferKey = do nameContents <- withGivenBuffer bufferKey $ do fl <- gets file st <- streamB Forward 0 return (fl, st) case nameContents of (Just f, contents) -> io (doesDirectoryExist f) >>= \case True -> printMsg "Can't save over a directory, doing nothing." >> return False False -> do hooks <- view preSaveHooks <$> askCfg mapM_ runAction hooks mayErr <- liftBase $ R.writeFile f contents io getCurrentTime >>= withGivenBuffer bufferKey . markSavedB return True (Nothing, _) -> printMsg "Buffer not associated with a file" >> return False -- | Write current buffer to disk as @f@. The file is also set to @f@. fwriteToE :: T.Text -> YiM Bool fwriteToE f = do b <- gets currentBuffer setFileName b (T.unpack f) fwriteBufferE b -- | Write all open buffers fwriteAllY :: YiM Bool fwriteAllY = do modifiedBuffers <- filterM deservesSave =<< gets bufferSet and <$> mapM fwriteBufferE (fmap bkey modifiedBuffers) -- | Make a backup copy of file backupE :: FilePath -> YiM () backupE = error "backupE not implemented" -- | Associate buffer with file; canonicalize the given path name. setFileName :: BufferRef -> FilePath -> YiM () setFileName b filename = do cfn <- liftBase $ userToCanonPath filename withGivenBuffer b $ (.=) identA $ FileBuffer cfn -- | Checks if the given buffer deserves a save: whether it's a file -- buffer and whether it's pointing at a file rather than a directory. deservesSave :: FBuffer -> YiM Bool deservesSave b | isUnchangedBuffer b = return False | otherwise = isFileBuffer b -- | Is there a proper file associated with the buffer? -- In other words, does it make sense to offer to save it? isFileBuffer :: FBuffer -> YiM Bool isFileBuffer b = case b ^. identA of MemBuffer _ -> return False FileBuffer fn -> not <$> liftBase (doesDirectoryExist fn) yi-core-0.19.4/src/Yi/History.hs0000644000000000000000000001262107346545000014514 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.History -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- ‘Command history’ implementation. module Yi.History where import Control.Applicative (liftA3) import Lens.Micro.Platform (Lens', lens, set, (^.)) import Data.Binary (Binary, get, put) import Data.Default (Default, def) import Data.List (nub) import qualified Data.Map as M (Map, findWithDefault, insert, mapKeys) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, isPrefixOf, null, pack, unpack) import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8) import Data.Typeable (Typeable) import Yi.Buffer (elemsB, replaceBufferContent) import Yi.Editor import qualified Yi.Rope as R (fromText, toText) import Yi.Types (YiVariable) newtype Histories = Histories (M.Map T.Text History) deriving (Show, Eq, Typeable) instance Binary Histories where put (Histories m) = put $ M.mapKeys T.unpack m get = Histories . M.mapKeys T.pack <$> get instance Default Histories where def = Histories def data History = History { _historyCurrent :: Int , _historyContents :: [T.Text] , _historyPrefix :: T.Text } deriving (Show, Eq, Typeable) instance Default History where def = History (-1) [] mempty instance Binary History where put (History cu co pr) = put cu >> put (map E.encodeUtf8 co) >> put (E.encodeUtf8 pr) get = liftA3 History get (fmap E.decodeUtf8 <$> get) (E.decodeUtf8 <$> get) instance YiVariable Histories dynKeyA :: (Default v, Ord k) => k -> Lens' (M.Map k v) v dynKeyA key = lens (M.findWithDefault def key) (flip (M.insert key)) miniBuffer :: T.Text miniBuffer = "minibuffer" historyUp :: EditorM () historyUp = historyMove miniBuffer 1 historyDown :: EditorM () historyDown = historyMove miniBuffer (-1) historyStart :: EditorM () historyStart = historyStartGen miniBuffer -- | Start an input session with History historyStartGen :: T.Text -> EditorM () historyStartGen ident = do Histories histories <- getEditorDyn let (History _cur cont pref) = histories ^. dynKeyA ident setHistory ident (History 0 (nub ("":cont)) pref) histories historyFinish :: EditorM () historyFinish = historyFinishGen miniBuffer (R.toText <$> withCurrentBuffer elemsB) -- | Finish the current input session with history. historyFinishGen :: T.Text -> EditorM T.Text -> EditorM () historyFinishGen ident getCurValue = do Histories histories <- getEditorDyn let History _cur cont pref = histories ^. dynKeyA ident curValue <- getCurValue let cont' = dropWhile (curValue ==) . dropWhile T.null $ cont curValue `seq` -- force the new value, otherwise we'll hold -- on to the buffer from which it's computed cont' `seq` -- force checking the top of the history, -- otherwise we'll build up thunks setHistory ident (History (-1) (curValue:cont') pref) histories historyFind :: [T.Text] -> Int -> Int -> Int -> T.Text -> Int historyFind cont len cur delta pref = case (next < 0, next >= len) of (True,_) -> next (_,True) -> next (_,_) -> if pref `T.isPrefixOf` (cont !! next) then next else historyFind cont len cur deltaLarger pref where next = cur + delta deltaLarger = delta + signum delta historyMove :: T.Text -> Int -> EditorM () historyMove ident delta = do s <- historyMoveGen ident delta (R.toText <$> withCurrentBuffer elemsB) withCurrentBuffer . replaceBufferContent . R.fromText $ s historyMoveGen :: T.Text -> Int -> EditorM T.Text -> EditorM T.Text historyMoveGen ident delta getCurValue = do Histories histories <- getEditorDyn let History cur cont pref = histories ^. dynKeyA ident curValue <- getCurValue let len = length cont next = historyFind cont len cur delta pref nextValue = cont !! next case (next < 0, next >= len) of (True, _) -> do printMsg $ "end of " <> ident <> " history, no next item." return curValue (_, True) -> do printMsg $ "beginning of " <> ident <> " history, no previous item." return curValue (_,_) -> do let contents = take cur cont ++ [curValue] ++ drop (cur + 1) cont setHistory ident (History next contents pref) histories return nextValue historyPrefixSet :: T.Text -> EditorM () historyPrefixSet = historyPrefixSet' miniBuffer historyPrefixSet' :: T.Text -> T.Text -> EditorM () historyPrefixSet' ident pref = do Histories histories <- getEditorDyn let History cur cont _pref = histories ^. dynKeyA ident setHistory ident (History cur cont pref) histories -- | Helper that sets the given history at ident and 'putEditorDyn's -- the result. setHistory :: (MonadEditor m, Functor m) => T.Text -- ^ identifier -> History -- ^ History to set -> M.Map T.Text History -- ^ Map of existing histories -> m () setHistory i h = putEditorDyn . Histories . set (dynKeyA i) h yi-core-0.19.4/src/Yi/Hoogle.hs0000644000000000000000000000731707346545000014276 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Hoogle -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Provides functions for calling Hoogle on the commandline, and -- processing results into a form useful for completion or insertion. module Yi.Hoogle where import Control.Arrow ((&&&)) import Data.Char (isUpper) import Data.List (nub) import qualified Data.Text as T (isInfixOf, lines, unpack) import System.Exit (ExitCode (ExitFailure)) import Yi.Buffer (readRegionB, regionOfB, replaceRegionB, unitWord) import Yi.Editor (printMsgs, withCurrentBuffer) import Yi.Keymap (YiM) import Yi.Process (runProgCommand) import qualified Yi.Rope as R (YiString, fromText, head, null, toString, toText, words) import Yi.String (showT) import Yi.Utils (io) -- | Remove anything starting with uppercase letter. These denote -- either module names or types. caseSensitize :: [R.YiString] -> [R.YiString] caseSensitize = filter p where p :: R.YiString -> Bool p t = case R.head t of Nothing -> False Just c -> not $ isUpper c -- | Hoogle's output includes a sort of type keyword, telling whether -- a hit is a package name, syntax, a module name, etc. But we care -- primarily about the function names, so we filter out anything -- containing the keywords. gv :: [R.YiString] -> [R.YiString] gv = filter f where ks = ["module ", " type ", "package ", " data ", " keyword "] f x = not $ any (`T.isInfixOf` R.toText x) ks -- | Query Hoogle, with given search and options. This errors out on no -- results or if the hoogle command is not on path. hoogleRaw :: R.YiString -> R.YiString -> IO [R.YiString] hoogleRaw srch opts = do let options = filter (not . R.null) [opts, srch] outp@(_status, out, _err) <- runProgCommand "hoogle" (R.toString <$> options) case outp of (ExitFailure 1, "", "") -> -- no output, probably failed to run binary fail "Error running hoogle command. Is hoogle on path?" (ExitFailure 1, xs, _) -> fail $ "hoogle failed with: " ++ T.unpack xs _ -> return () -- TODO: bench ‘R.fromText . T.lines’ vs ‘R.lines . R.fromText’ let results = fmap R.fromText . T.lines $ out if results == ["No results found"] then fail "No Hoogle results" else return results -- | Filter the output of 'hoogleRaw' to leave just functions. hoogleFunctions :: R.YiString -> IO [R.YiString] hoogleFunctions a = caseSensitize . gv . nub . map ((!!1) . R.words) <$> hoogleRaw a "" -- | Return module-function pairs. hoogleFunModule :: R.YiString -> IO [(R.YiString, R.YiString)] hoogleFunModule a = map ((head &&& (!! 1)) . R.words) . gv <$> hoogleRaw a "" -- | Call out to 'hoogleFunModule', and overwrite the word at point with -- the first returned function. hoogle :: YiM R.YiString hoogle = do (wordRegion,word) <- withCurrentBuffer $ do wordRegion <- regionOfB unitWord word <- readRegionB wordRegion return (wordRegion, word) ((modl,fun):_) <- io $ hoogleFunModule word withCurrentBuffer $ replaceRegionB wordRegion fun return modl -- | Call out to 'hoogleRaw', and print inside the Minibuffer the results of -- searching Hoogle with the word at point. hoogleSearch :: YiM () hoogleSearch = do word <- withCurrentBuffer $ do wordRegion <- regionOfB unitWord readRegionB wordRegion results <- io $ hoogleRaw word "" -- The quotes help legibility between closely-packed results printMsgs $ map showT results yi-core-0.19.4/src/Yi/Hooks.hs0000644000000000000000000000662407346545000014144 0ustar0000000000000000{- | This module provides assistance in implementing \"hooks\" in Yi. This module provides no major new functionality -- only assistance in using 'YiConfigVariable's more easily to implement hooks. We consider a simple example. Suppose we have a function > promptForFile :: Maybe FilePath -> YiM FilePath which prompts the user to select a file from their file system, starting with the provided directory (if actually provided). Since this is a frequent task in Yi, it is important for it to be as user-friendly as possible. If opinions vary on the meaning of \"user-friendly\", then we would really like to provide multiple implementations of @promptForFile@, and allow users to select which implementation to use in their config files. A way to achieve this is using hooks, as follows: > -- create a new type > newtype FilePrompter = FilePrompter > { runFilePrompter :: Maybe FilePath -> YiM FilePath } > deriving (Typeable) > $(nameDeriveAccessors ''FilePrompter (n -> Just (n ++ "A"))) > > -- give some implementations > filePrompter1, filePrompter2, filePrompter3 :: FilePrompter > ... > > -- declare FilePrompter as a YiConfigVariable (so it can go in the Config) > instance YiConfigVariable FilePrompter > > -- specify the default FilePrompter > instance Default FilePrompter where > def = filePrompter1 > > -- replace the old promptForFile function with a shim > promptForFile :: Maybe FilePath -> YiM FilePath > promptForFile = runHook runFilePrompter > > -- provide a custom-named Field for Yi.Config.Simple (not > -- strictly necessary, but user-friendly) > filePrompter :: Field FilePrompter > filePrompter = customVariable The user can write > ... > filePrompter %= filePrompter2 > ... in their config file, and calls to @promptForFile@ will now use the different prompter. Library code which called @promptForFile@ does not need to be changed, but it gets the new @filePrompter2@ behaviour automatically. See "Yi.Eval" for a real example of hooks. -} module Yi.Hooks( -- * Convenience function 'runHook' runHook, HookType, -- * Re-exports from "Yi.Config.Simple" customVariable, Field, ) where import Lens.Micro.Platform ((^.)) import Yi.Config (configVariable) import Yi.Config.Simple.Types (Field, customVariable) import Yi.Editor (EditorM, askCfg) import Yi.Keymap (YiM) import Yi.Types (YiConfigVariable) -- | Looks up the configured value for the hook, and runs it. The -- argument to 'runHook' will typically be a record accessor. See -- 'HookType' for the valid hook types. runHook :: (HookType ty, YiConfigVariable var) => (var -> ty) -> ty runHook = runHookImpl -- | The class of \"valid hooks\". This class is exported abstractly, -- but the instances can be phrased quite simply: the functions (of -- arbitrarily many arguments, including zero) which run in either the -- 'EditorM' or 'YiM' monads. -- --A typical example would be something like -- -- @Int -> String -> 'EditorM' String@. class HookType ty where runHookImpl :: YiConfigVariable var => (var -> ty) -> ty instance HookType (EditorM a) where runHookImpl lookupHook = do cfg <- askCfg lookupHook (cfg ^. configVariable) instance HookType (YiM a) where runHookImpl lookupHook = do cfg <- askCfg lookupHook (cfg ^. configVariable) instance HookType b => HookType (a -> b) where runHookImpl lookupHook a = runHookImpl (($a) . lookupHook) yi-core-0.19.4/src/Yi/IncrementalParse.hs0000644000000000000000000000301107346545000016300 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} module Yi.IncrementalParse (recoverWith, symbol, eof, lookNext, testNext, State, P, Parser(..), AlexState (..), scanner) where import Parser.Incremental (Parser (..), Process, eof, evalL, evalR, lookNext, mkProcess, pushEof, pushSyms, recoverWith, symbol, testNext) import Yi.Lexer.Alex (AlexState (..)) import Yi.Syntax (Scanner (..)) type P s a = Parser s a type State st token result = (st, Process token result) scanner :: forall st token result. Parser token result -> Scanner st token -> Scanner (State st token result) result scanner parser input = Scanner { scanInit = (scanInit input, mkProcess parser), scanLooked = scanLooked input . fst, scanRun = run, scanEmpty = fst $ evalR $ pushEof $ mkProcess parser } where run :: State st token result -> [(State st token result, result)] run (st,process) = updateState0 process $ scanRun input st updateState0 :: Process token result -> [(st,token)] -> [(State st token result, result)] updateState0 _ [] = [] updateState0 curState toks@((st,tok):rest) = ((st, curState), result) : updateState0 nextState rest where !nextState = evalL $ pushSyms [tok] curState result = fst $ evalR $ pushEof $ pushSyms (fmap snd toks) curState yi-core-0.19.4/src/Yi/Interact.hs0000644000000000000000000002675407346545000014640 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK show-extensions #-} {-| Module : Yi.Interact License : GPL-2 Maintainer : yi-devel@googlegroups.com Stability : experimental Portability : portable This is a library of interactive processes combinators, usable to define extensible keymaps. (Inspired by the Parsec library, written by Koen Claessen) The processes are: * composable: in parallel using '<|>', in sequence using monadic bind. * extensible: it is always possible to override a behaviour by combination of 'adjustPriority' and '<|>'. (See also '<||' for a convenient combination of the two.) * monadic: sequencing is done via monadic bind. (leveraging the whole battery of monadic tools that Haskell provides) The processes can parse input, and write output that depends on it. The semantics are quite obvious; only disjunction deserve a bit more explanation: in @p = (a '<|>' b)@, what happens if @a@ and @b@ recognize the same input (prefix), but produce conflicting output? * if the output is the same (as by the Eq class), then the processes (prefixes) are "merged" * if a Write is more prioritized than the other, the one with low priority will be discarded * otherwise, the output will be delayed until one of the branches can be discarded. * if there is no way to disambiguate, then no output will be generated anymore. This situation can be detected by using 'possibleActions' however. -} module Yi.Interact ( I, P (Chain,End), InteractState (..), MonadInteract (..), deprioritize, important, (<||), (||>), option, oneOf, processOneEvent, computeState, event, events, choice, mkAutomaton, idAutomaton, runWrite, anyEvent, eventBetween, accepted ) where import Control.Applicative (Alternative ((<|>), empty)) import Control.Arrow (first) import Lens.Micro.Platform (_1, _2, view) import qualified Control.Monad.Fail as Fail import Control.Monad.State (MonadTrans (lift), StateT) import Control.Monad (MonadPlus(..)) import Data.Function (on) import Data.List (groupBy) import qualified Data.Text as T (Text, append, pack) ------------------------------------------------ -- Classes -- | Abstraction of monadic interactive processes class (Eq w, Monad m, Alternative m, Applicative m, MonadPlus m) => MonadInteract m w e | m -> w e where write :: w -> m () -- ^ Outputs a result. eventBounds :: Ord e => Maybe e -> Maybe e -> m e -- ^ Consumes and returns the next character. -- Fails if there is no input left, or outside the given bounds. adjustPriority :: Int -> m () ------------------------------------------------- -- State transformation -- Needs -fallow-undecidable-instances -- TODO: abstract over MonadTransformer instance MonadInteract m w e => MonadInteract (StateT s m) w e where write = lift . write eventBounds l h = lift (eventBounds l h) adjustPriority p = lift (adjustPriority p) --------------------------------------------------------------------------- -- | Interactive process description -- TODO: Replace 'Doc:' by ^ when haddock supports GADTs data I ev w a where Returns :: a -> I ev w a Binds :: I ev w a -> (a -> I ev w b) -> I ev w b Gets :: Ord ev => Maybe ev -> Maybe ev -> I ev w ev -- Doc: Accept any character between given bounds. Bound is ignored if 'Nothing'. Fails :: I ev w a Writes :: w -> I ev w () Priority :: Int -> I ev w () Plus :: I ev w a -> I ev w a -> I ev w a instance Functor (I event w) where fmap f i = pure f <*> i instance Applicative (I ev w) where pure = return a <*> b = do f <- a; x <- b; return (f x) instance Alternative (I ev w) where empty = Fails (<|>) = Plus instance Monad (I event w) where return = Returns (>>=) = Binds #if (!MIN_VERSION_base(4,13,0)) fail _ = Fails #endif instance Fail.MonadFail (I event w) where fail _ = Fails instance Eq w => MonadPlus (I event w) where mzero = Fails mplus = Plus instance Eq w => MonadInteract (I event w) w event where write = Writes eventBounds = Gets adjustPriority = Priority infixl 3 <|| deprioritize :: (MonadInteract f w e) => f () deprioritize = adjustPriority 1 (<||), (||>) :: (MonadInteract f w e) => f a -> f a -> f a a <|| b = a <|> (deprioritize >> b) (||>) = flip (<||) -- | Just like '(<||)' but in prefix form. It 'deprioritize's the -- second argument. important :: MonadInteract f w e => f a -> f a -> f a important a b = a <|| b -- | Convert a process description to an "executable" process. mkProcess :: Eq w => I ev w a -> (a -> P ev w) -> P ev w mkProcess (Returns x) = \fut -> fut x mkProcess Fails = const Fail mkProcess (m `Binds` f) = \fut -> mkProcess m (\a -> mkProcess (f a) fut) mkProcess (Gets l h) = Get l h mkProcess (Writes w) = \fut -> Write w (fut ()) mkProcess (Priority p) = \fut -> Prior p (fut ()) mkProcess (Plus a b) = \fut -> Best (mkProcess a fut) (mkProcess b fut) ---------------------------------------------------------------------- -- Process type -- | Operational representation of a process data P event w = Ord event => Get (Maybe event) (Maybe event) (event -> P event w) | Fail | Write w (P event w) | Prior Int (P event w) -- low numbers indicate high priority | Best (P event w) (P event w) | End | forall mid. (Show mid, Eq mid) => Chain (P event mid) (P mid w) accepted :: (Show ev) => Int -> P ev w -> [[T.Text]] accepted 0 _ = [[]] accepted d (Get (Just low) (Just high) k) = do t <- accepted (d - 1) (k low) let h = if low == high then showT low else showT low `T.append` ".." `T.append` showT high return (h : t) accepted _ (Get Nothing Nothing _) = [[""]] accepted _ (Get Nothing (Just e) _) = [[".." `T.append` showT e]] accepted _ (Get (Just e) Nothing _) = [[showT e `T.append` ".."]] accepted _ Fail = [] accepted _ (Write _ _) = [[]] -- this should show what action we get... accepted d (Prior _ p) = accepted d p accepted d (Best p q) = accepted d p ++ accepted d q accepted _ End = [] accepted _ (Chain _ _) = error "accepted: chain not supported" -- Utility function showT :: Show a => a -> T.Text showT = T.pack . show -- --------------------------------------------------------------------------- -- Operations over P runWrite :: Eq w => P event w -> [event] -> [w] runWrite _ [] = [] runWrite p (c:cs) = let (ws, p') = processOneEvent p c in ws ++ runWrite p' cs processOneEvent :: Eq w => P event w -> event -> ([w], P event w) processOneEvent p e = pullWrites $ pushEvent p e -- | Push an event in the automaton pushEvent :: P ev w -> ev -> P ev w pushEvent (Best c d) e = Best (pushEvent c e) (pushEvent d e) pushEvent (Write w c) e = Write w (pushEvent c e) pushEvent (Prior p c) e = Prior p (pushEvent c e) pushEvent (Get l h f) e = if test (e >=) l && test (e <=) h then f e else Fail where test = maybe True pushEvent Fail _ = Fail pushEvent End _ = End pushEvent (Chain p q) e = Chain (pushEvent p e) q -- | Abstraction of the automaton state. data InteractState event w = Ambiguous [(Int,w,P event w)] | Waiting | Dead | Running w (P event w) #if __GLASGOW_HASKELL__ >= 804 instance Semigroup (InteractState event w) where (<>) = mappend #endif instance Monoid (InteractState event w) where -- not used at the moment: mappend (Running w c) _ = Running w c mappend _ (Running w c) = Running w c -- don't die if that can be avoided mappend Dead p = p mappend p Dead = p -- If a branch is not determined, wait for it. mappend Waiting _ = Waiting mappend _ Waiting = Waiting -- ambiguity remains mappend (Ambiguous a) (Ambiguous b) = Ambiguous (a ++ b) mempty = Ambiguous [] -- | find all the writes that are accessible. findWrites :: Int -> P event w -> InteractState event w findWrites p (Best c d) = findWrites p c `mappend` findWrites p d findWrites p (Write w c) = Ambiguous [(p,w,c)] findWrites p (Prior dp c) = findWrites (p+dp) c findWrites _ Fail = Dead findWrites _ End = Dead findWrites _ (Get{}) = Waiting findWrites p (Chain a b) = case computeState a of Dead -> Dead Ambiguous _ -> Dead -- If ambiguity, don't try to do anything clever for now; die. Running w c -> findWrites p (Chain c (pushEvent b w)) -- pull as much as possible from the left automaton Waiting -> case findWrites p b of Ambiguous choices -> Ambiguous [(p',w',Chain a c') | (p',w',c') <- choices] Running w' c' -> Running w' (Chain a c') -- when it has nothing more, pull from the right. Dead -> Dead Waiting -> Waiting computeState :: Eq w => P event w -> InteractState event w computeState a = case findWrites 0 a of Ambiguous actions -> let prior = minimum $ map (view _1) actions bests = groupBy ((==) `on` view _2) $ filter ((prior ==) . view _1) actions in case bests of [(_,w,c):_] -> Running w c _ -> Ambiguous $ map head bests s -> s pullWrites :: Eq w => P event w -> ([w], P event w) pullWrites a = case computeState a of Running w c -> first (w:) (pullWrites c) _ -> ([], a) instance (Show w, Show ev) => Show (P ev w) where show (Get Nothing Nothing _) = "?" show (Get (Just l) (Just h) _p) | l == h = show l -- ++ " " ++ show (p l) show (Get l h _) = maybe "" show l ++ ".." ++ maybe "" show h show (Prior p c) = ":" ++ show p ++ show c show (Write w c) = "!" ++ show w ++ "->" ++ show c show (End) = "." show (Fail) = "*" show (Best p q) = "{" ++ show p ++ "|" ++ show q ++ "}" show (Chain a b) = show a ++ ">>>" ++ show b -- --------------------------------------------------------------------------- -- Derived operations oneOf :: (Ord event, MonadInteract m w event, Fail.MonadFail m) => [event] -> m event oneOf s = choice $ map event s anyEvent :: (Ord event, MonadInteract m w event) => m event anyEvent = eventBounds Nothing Nothing eventBetween :: (Ord e, MonadInteract m w e) => e -> e -> m e eventBetween l h = eventBounds (Just l) (Just h) event :: (Ord event, MonadInteract m w event) => event -> m event -- ^ Parses and returns the specified character. event e = eventBetween e e events :: (Ord event, MonadInteract m w event) => [event] -> m [event] -- ^ Parses and returns the specified list of events (lazily). events = mapM event choice :: (MonadInteract m w e, Fail.MonadFail m) => [m a] -> m a -- ^ Combines all parsers in the specified list. choice [] = fail "No choice succeeds" choice [p] = p choice (p:ps) = p `mplus` choice ps option :: (MonadInteract m w e) => a -> m a -> m a -- ^ @option x p@ will either parse @p@ or return @x@ without consuming -- any input. option x p = p `mplus` return x mkAutomaton :: Eq w => I ev w a -> P ev w mkAutomaton i = mkProcess i (const End) -- An automaton that produces its input idAutomaton :: (Ord a, Eq a) => P a a idAutomaton = Get Nothing Nothing $ \e -> Write e idAutomaton -- It would be much nicer to write: -- mkAutomaton (forever 0 (anyEvent >>= write)) -- however this creates a memory leak. Unfortunately I don't understand why. -- To witness: -- dist/build/yi/yi +RTS -hyI -hd -- Then type some characters. (Binds grows linearly) yi-core-0.19.4/src/Yi/JumpList.hs0000644000000000000000000000251207346545000014620 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} module Yi.JumpList ( JumpList , Jump(..) , addJump , jumpBack , jumpForward ) where import GHC.Generics (Generic) import Data.Binary (Binary) import Data.List.PointedList as PL (PointedList (..), next, previous) import Yi.Buffer.Basic (BufferRef, Mark) type JumpList = Maybe (PL.PointedList Jump) data Jump = Jump { jumpMark :: Mark , jumpBufferRef :: BufferRef } deriving (Generic) instance Binary Jump instance Show Jump where show (Jump mark bufref) = "" addJump :: Jump -> JumpList -> JumpList addJump j (Just (PL.PointedList past present _future)) = Just $ PL.PointedList (present:past) j [] addJump j Nothing = Just $ PL.PointedList [] j [] jumpBack :: JumpList -> JumpList jumpBack = modifyJumpList previous jumpForward :: JumpList -> JumpList jumpForward = modifyJumpList next modifyJumpList :: (PointedList Jump -> Maybe (PointedList Jump)) -> JumpList -> JumpList modifyJumpList f (Just jumps) = case f jumps of Nothing -> Just jumps Just jumps' -> Just jumps' modifyJumpList _ Nothing = Nothing yi-core-0.19.4/src/Yi/Keymap.hs0000644000000000000000000000767607346545000014317 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Keymap -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- 'Keymap', 'YiM' and 'Action's. module Yi.Keymap ( Action(..) , emptyAction , Interact , KeymapM , Keymap , KeymapEndo , KeymapProcess , KeymapSet(..) , topKeymapA , insertKeymapA , extractTopKeymap , modelessKeymapSet , YiM(..) , withUI , unsafeWithEditor , readEditor , catchDynE , catchJustE , handleJustE , YiAction (..) , Yi(..) , IsRefreshNeeded(..) , YiVar(..) , write , withModeY -- * Lenses , yiSubprocessesA , yiEditorA , yiSubprocessIdSupplyA , yiConfigA , yiInputA , yiOutputA , yiUiA , yiVarA ) where import Control.Exception (Exception, catch, catchJust) import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) import Control.Monad.State (gets) import Yi.Buffer () import qualified Yi.Editor as Editor (currentBuffer, findBuffer) import qualified Yi.Interact as I (MonadInteract, write) import Yi.Monad (with) import Yi.Types import Yi.UI.Common (UI) import Yi.Utils (io, makeLensesWithSuffix) ----------------------- -- Keymap basics -- | @write a@ returns a keymap that just outputs the action @a@. write :: (I.MonadInteract m Action ev, YiAction a x, Show x) => a -> m () write x = I.write (makeAction x) -------------------------------- -- Uninteresting glue code withUI :: (UI Editor -> IO a) -> YiM a withUI = with yiUi readEditor :: MonadEditor m => (Editor -> a) -> m a readEditor f = withEditor (gets f) catchDynE :: Exception exception => YiM a -> (exception -> YiM a) -> YiM a catchDynE (YiM inner) handler = YiM $ ReaderT (\r -> catch (runReaderT inner r) (\e -> runReaderT (runYiM $ handler e) r)) catchJustE :: (Exception e) => (e -> Maybe b) -- ^ Predicate to select exceptions -> YiM a -- ^ Computation to run -> (b -> YiM a) -- ^ Handler -> YiM a catchJustE p (YiM c) h = YiM $ ReaderT (\r -> catchJust p (runReaderT c r) (\b -> runReaderT (runYiM $ h b) r)) handleJustE :: (Exception e) => (e -> Maybe b) -> (b -> YiM a) -> YiM a -> YiM a handleJustE p h c = catchJustE p c h -- ------------------------------------------- class YiAction a x | a -> x where makeAction :: Show x => a -> Action instance YiAction (IO x) x where makeAction = YiA . io instance YiAction (YiM x) x where makeAction = YiA instance YiAction (EditorM x) x where makeAction = EditorA instance YiAction (BufferM x) x where makeAction = BufferA instance YiAction Action () where makeAction = id makeLensesWithSuffix "A" ''KeymapSet modelessKeymapSet :: Keymap -> KeymapSet modelessKeymapSet k = KeymapSet { insertKeymap = k , topKeymap = k } -- | @withModeY f@ runs @f@ on the current buffer's mode. As this runs in -- the YiM monad, we're able to do more than with just 'withModeB' such as -- prompt the user for something before running the action. withModeY :: (forall syntax. Mode syntax -> YiM ()) -> YiM () withModeY f = do bufref <- gets Editor.currentBuffer mfbuf <- Editor.findBuffer bufref case mfbuf of Nothing -> return () Just (FBuffer {bmode = m}) -> f m makeLensesWithSuffix "A" ''YiVar makeLensesWithSuffix "A" ''Yi yi-core-0.19.4/src/Yi/Keymap/0000755000000000000000000000000007346545000013743 5ustar0000000000000000yi-core-0.19.4/src/Yi/Keymap/Keys.hs0000644000000000000000000000720507346545000015216 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Keymap.Keys -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Combinators for building keymaps. module Yi.Keymap.Keys ( module Yi.Event, module Yi.Interact, printableChar, textChar, charOf, shift, meta, ctrl, super, hyper, spec, char, (>>!), (>>=!), (?>>), (?>>!), (?*>>), (?*>>!), ctrlCh, metaCh, hyperCh, optMod, pString ) where import Prelude hiding (error) import Control.Monad (unless) import qualified Control.Monad.Fail as Fail import Data.Char (isAlpha, isPrint, toUpper) import Data.List (nub, sort) import Yi.Debug (error) import Yi.Event (Event (..), Key (..), Modifier (..), eventToChar, prettyEvent) import Yi.Interact hiding (write) import Yi.Keymap (Action, KeymapM, YiAction, write) printableChar :: (Fail.MonadFail m, MonadInteract m w Event) => m Char printableChar = do Event (KASCII c) [] <- anyEvent unless (isPrint c) $ fail "unprintable character" return c -- | Parse any character that can be inserted in the text. textChar :: KeymapM Char textChar = do -- Why only ASCII? Event (KASCII c) [] <- anyEvent return c pString :: (MonadInteract m w Event) => String -> m [Event] pString = events . map char charOf :: (Fail.MonadFail m, MonadInteract m w Event) => (Event -> Event) -> Char -> Char -> m Char charOf modifier l h = do Event (KASCII c) _ <- eventBetween (modifier $ char l) (modifier $ char h) return c shift,ctrl,meta,super,hyper :: Event -> Event shift (Event (KASCII c) ms) | isAlpha c = Event (KASCII (toUpper c)) ms | otherwise = error "shift: unhandled event" shift (Event k ms) = Event k $ nub $ sort (MShift:ms) ctrl (Event k ms) = Event k $ nub $ sort (MCtrl:ms) meta (Event k ms) = Event k $ nub $ sort (MMeta:ms) super (Event k ms) = Event k $ nub $ sort (MSuper:ms) hyper (Event k ms) = Event k $ nub $ sort (MHyper:ms) char :: Char -> Event char '\t' = Event KTab [] char '\r' = Event KEnter [] char '\n' = Event KEnter [] char c = Event (KASCII c) [] ctrlCh :: Char -> Event ctrlCh = ctrl . char metaCh :: Char -> Event metaCh = meta . char hyperCh :: Char -> Event hyperCh = hyper . char -- | @optMod f ev@ produces a 'MonadInteract' that consumes @ev@ or @f ev@ optMod ::(Fail.MonadFail m, MonadInteract m w Event) => (Event -> Event) -> Event -> m Event optMod f ev = oneOf [ev, f ev] -- | Convert a special key into an event spec :: Key -> Event spec k = Event k [] -- | > p >>! act = p >> 'write' act (>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => m b -> a -> m () p >>! act = p >> write act -- | > p >>=! act = p >>= 'write' . act (>>=!) :: (MonadInteract m Action Event, YiAction a x, Show x) => m b -> (b -> a) -> m () p >>=! act = p >>= write . act -- | @ ev ?>> proc = 'event' ev >> proc @ (?>>) :: (MonadInteract m action Event) => Event -> m a -> m a ev ?>> proc = event ev >> proc -- | @ ev ?>>! act = 'event' ev >> 'write' act @ (?>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => Event -> a -> m () ev ?>>! act = event ev >> write act -- | @ ev ?*>> proc = 'events' ev >> proc @ (?*>>) :: (MonadInteract m action Event) => [Event] -> m a -> m a ev ?*>> proc = events ev >> proc -- | @ ev ?*>>! act = 'events' ev >> 'write' act @ (?*>>!) :: (MonadInteract m Action Event, YiAction a x, Show x) => [Event] -> a -> m () ev ?*>>! act = events ev >> write act infixl 1 >>! infixl 1 >>=! infixr 0 ?>>! infixr 0 ?>> infixr 0 ?*>>! infixr 0 ?*>> yi-core-0.19.4/src/Yi/KillRing.hs0000644000000000000000000000555207346545000014573 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.KillRing -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Killring operations. module Yi.KillRing ( Killring , _krKilled , _krContents , krKilled , krContents , krEndCmd , krPut , krSet, krGet , krEmpty , krLastYank ) where import Prelude hiding (head, tail, take) import Lens.Micro.Platform ((^.), makeLenses) import Data.Binary (Binary, get, put) import Data.List.NonEmpty (NonEmpty (..), head, take) import Data.Monoid ((<>)) import Yi.Buffer.Basic (Direction (..)) import qualified Yi.Rope as R (YiString, length) data Killring = Killring { _krKilled :: !Bool , _krAccumulate :: !Bool , _krContents :: !(NonEmpty R.YiString) , _krLastYank :: !Bool } deriving (Show, Eq) instance Binary Killring where put (Killring k a c l) = let putNE (x :| xs) = put x >> put xs in put k >> put a >> putNE c >> put l get = let getNE = (:|) <$> get <*> get in Killring <$> get <*> get <*> getNE <*> get makeLenses ''Killring maxDepth :: Int maxDepth = 10 krEmpty :: Killring krEmpty = Killring { _krKilled = False , _krAccumulate = False , _krContents = mempty :| mempty , _krLastYank = False } -- | Finish an atomic command, for the purpose of killring accumulation. krEndCmd :: Killring -> Killring krEndCmd kr = kr { _krKilled = False , _krAccumulate = kr ^. krKilled } -- | Put some text in the killring. -- It's accumulated if the last command was a kill too krPut :: Direction -> R.YiString -> Killring -> Killring krPut dir s kr@Killring { _krContents = r@(x :| xs) } = kr { _krKilled = True , _krContents = if kr ^. krAccumulate then (case dir of Forward -> x <> s Backward -> s <> x) :| xs else push s r } -- | Push a string in the killring. push :: R.YiString -> NonEmpty R.YiString -> NonEmpty R.YiString push s r@(h :| t) = s :| if R.length h <= 1 then t else take maxDepth r -- Don't save very small cutted text portions. -- | Set the top of the killring. Never accumulate the previous content. krSet :: R.YiString -> Killring -> Killring krSet s kr@Killring {_krContents = _ :| xs} = kr {_krContents = s :| xs} -- | Get the top of the killring. krGet :: Killring -> R.YiString krGet = head . _krContents yi-core-0.19.4/src/Yi/Layout.hs0000644000000000000000000004044207346545000014332 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- we might as well unbox our Ints. -- | This module defines the layout manager interface (see 'LayoutManager'). To desgin a new layout manager, just make an instance of this class. module Yi.Layout ( -- * Concrete layouts Layout(..), Orientation(..), DividerPosition, DividerRef, RelativeSize, dividerPositionA, findDivider, -- * Layout managers -- ** The interface LayoutManager(..), AnyLayoutManager(..), layoutManagerSameType, -- ** Standard managers wide, tall, slidyTall, slidyWide, hPairNStack, vPairNStack, -- * Utility functions -- ** Layouts as rectangles Rectangle(..), HasNeighborWest, layoutToRectangles, -- ** Transposing things Transposable(..), Transposed(..), -- ** 'DividerRef' combinators -- $divRefCombinators LayoutM, pair, singleWindow, stack, evenStack, runLayoutM, ) where import Control.Applicative ((<|>)) import Control.Arrow (first) import Lens.Micro.Platform (Lens', lens) import qualified Control.Monad.State.Strict as Monad (State, evalState, get, put) import Data.Default (Default, def) import Data.List (foldl', mapAccumL) import Data.Maybe (fromMaybe, isNothing) import Data.Typeable (Typeable, cast, typeOf) -------------------------------- Some design notes ---------------------- -- [Treatment of mini windows] -- Mini windows are not subject to layout; instead, they are always -- placed at the bottom of the screen. There are multiple reasons for -- this, as discussed in -- https://groups.google.com/d/topic/yi-devel/vhTObC25dpY/discussion, one -- being that for many layouts, the bottom (or top) of the screen is the -- only reasonable place for mini windows (for example, think about -- side-by-side layouts). -- [Design of the 'Layout' datatype] -- The 'Layout' datatype is currently implemented in terms of -- horizontal stacks and vertical stacks. An alternative approach, -- which xmonad uses, is the following: a 'Layout a' could be a -- function @a -> Rectangle@ which specifies in coordinates where a -- window should be placed. -- -- While this alternative is more flexible than the current approach -- in allowing spiral layouts and the like, the vty UI doesn't support -- this: only vertical and horizontal composition of images is -- allowed. ----------------------------------- Concrete 'Layout's. -- | UI-agnostic layout schema. The basic constructs are -- (horizontal/vertical) stacks with fixed ratios between window -- sizes; and (horizontal/vertical) pairs with a slider in between (if -- available). data Layout a = SingleWindow a | Stack { orientation :: !Orientation, -- ^ Orientation wins :: [(Layout a, RelativeSize)] -- ^ The layout stack, with the given weights -- TODO: fix strictness for stack (it's still lazy) } | Pair { orientation :: !Orientation, -- ^ Orientation divPos :: !DividerPosition, -- ^ Initial position of the divider divRef :: !DividerRef, -- ^ Index of the divider (for updating the divider position) pairFst :: !(Layout a), -- ^ Upper of of the pair pairSnd :: !(Layout a) -- ^ Lower of the pair } deriving(Typeable, Eq, Functor) -- | Accessor for the 'DividerPosition' with given reference dividerPositionA :: DividerRef -> Lens' (Layout a) DividerPosition dividerPositionA ref = lens getter (flip setter) where setter pos = set' where set' s@(SingleWindow _) = s set' p@Pair{} | divRef p == ref = p{ divPos = pos } | otherwise = p{ pairFst = set' (pairFst p), pairSnd = set' (pairSnd p) } set' s@Stack{} = s{ wins = fmap (first set') (wins s) } getter = fromMaybe invalidRef . get' get' (SingleWindow _) = Nothing get' p@Pair{} | divRef p == ref = Just (divPos p) | otherwise = get' (pairFst p) <|> get' (pairSnd p) get' s@Stack{} = foldl' (<|>) Nothing (fmap (get' . fst) (wins s)) invalidRef = error "Yi.Layout.dividerPositionA: invalid DividerRef" -- | Find the divider nearest to a given window, or just the first one -- in case the argument is 'Nothing' findDivider :: Eq a => Maybe a -> Layout a -> Maybe DividerRef findDivider mbw = go [] where go path (SingleWindow w) = maybe Nothing (\w' -> if w == w' && not (null path) then Just (head path) else Nothing) mbw go path (Pair _ _ ref l1 l2) = if isNothing mbw then Just ref else let p' = ref : path in go p' l1 <|> go p' l2 go path (Stack _ ws) = foldr (<|>) Nothing $ map (go path . fst) ws instance Show a => Show (Layout a) where show (SingleWindow a) = show a show (Stack o s) = show o ++ " stack " ++ show s show p@(Pair{}) = show (orientation p) ++ " " ++ show (pairFst p, pairSnd p) -- | The def layout consists of a single window instance Default a => Default (Layout a) where def = SingleWindow def -- | Orientations for 'Stack' and 'Pair' data Orientation = Horizontal | Vertical deriving(Eq, Show) -- | Divider reference type DividerRef = Int -- | Divider position, in the range (0,1) type DividerPosition = Double -- | Relative sizes, for 'Stack' type RelativeSize = Double ----------------------------------------------------- Layout managers -- TODO: add Binary requirement when possible -- | The type of layout managers. See the layout managers 'tall', 'hPairNStack' and 'slidyTall' for some example implementations. class (Typeable m, Eq m) => LayoutManager m where -- | Given the old layout and the new list of windows, construct a -- layout for the new list of windows. -- -- If the layout manager uses sliding dividers, then a user will expect that most -- of these dividers don't move when adding a new window. It is the layout -- manager's responsibility to ensure that this is the case, and this is the -- purpose of the @Layout a@ argument. -- -- The old layout may come from a different layout manager, in which case the layout manager is free to ignore it. pureLayout :: m -> Layout a -> [a] -> Layout a -- | Describe the layout in a form suitable for the user. describeLayout :: m -> String -- | Cycles to the next variant, if there is one (the default is 'id') nextVariant :: m -> m nextVariant = id -- | Cycles to the previous variant, if there is one (the default is 'id' previousVariant :: m -> m previousVariant = id -- | Existential wrapper for 'Layout' data AnyLayoutManager = forall m. LayoutManager m => AnyLayoutManager !m deriving(Typeable) instance Eq AnyLayoutManager where (AnyLayoutManager l1) == (AnyLayoutManager l2) = maybe False (== l2) (cast l1) instance LayoutManager (AnyLayoutManager) where pureLayout (AnyLayoutManager l) = pureLayout l describeLayout (AnyLayoutManager l) = describeLayout l nextVariant (AnyLayoutManager l) = AnyLayoutManager (nextVariant l) previousVariant (AnyLayoutManager l) = AnyLayoutManager (previousVariant l) -- | The default layout is 'tallLayout' instance Default AnyLayoutManager where def = hPairNStack 1 -- | True if the internal layout managers have the same type (but are not necessarily equal). layoutManagerSameType :: AnyLayoutManager -> AnyLayoutManager -> Bool layoutManagerSameType (AnyLayoutManager l1) (AnyLayoutManager l2) = typeOf l1 == typeOf l2 ------------------------------ Standard layouts -- | Tall windows (i.e. places windows side-by-side, equally spaced) data Tall = Tall deriving(Eq, Typeable) -- | Windows placed side-by-side, equally spaced. tall :: AnyLayoutManager tall = AnyLayoutManager Tall instance LayoutManager Tall where pureLayout Tall _oldLayout ws = runLayoutM $ evenStack Horizontal (fmap singleWindow ws) describeLayout Tall = "Windows positioned side-by-side" -- | Wide windows (windows placed on top of one another, equally spaced) data Wide = Wide deriving(Eq, Typeable) instance LayoutManager Wide where pureLayout Wide _oldLayout ws = runLayoutM $ evenStack Vertical (fmap singleWindow ws) describeLayout Wide = "Windows positioned above one another" -- | Windows placed on top of one another, equally spaced wide :: AnyLayoutManager wide = AnyLayoutManager Wide -- | Tall windows, with arranged in a balanced binary tree with sliders in between them data SlidyTall = SlidyTall deriving(Eq, Typeable) -- | Tall windows, arranged in a balanced binary tree with sliders in between them. slidyTall :: AnyLayoutManager slidyTall = AnyLayoutManager SlidyTall instance LayoutManager SlidyTall where -- an error on input [] is easier to debug than an infinite loop. pureLayout SlidyTall _oldLayout [] = error "Yi.Layout: empty window list unexpected" pureLayout SlidyTall oldLayout xs = runLayoutM (go (Just oldLayout) xs) where go _layout [x] = singleWindow x go layout (splitList -> (lxs, rxs)) = case layout of -- if the old layout had a pair in the same point of the tree, use its divider position Just (Pair Horizontal pos _ l r) -> pair Horizontal pos (go (Just l) lxs) (go (Just r) rxs) -- otherwise, just use divider position 0.5 _ -> pair Horizontal 0.5 (go Nothing lxs) (go Nothing rxs) describeLayout SlidyTall = "Slidy tall windows, with balanced-position sliders" splitList :: [a] -> ([a], [a]) splitList xs = splitAt ((length xs + 1) `div` 2) xs -- | Transposed version of 'SlidyTall' newtype SlidyWide = SlidyWide (Transposed SlidyTall) deriving(Eq, Typeable) -- | Transposed version of 'slidyTall' slidyWide :: AnyLayoutManager slidyWide = AnyLayoutManager (SlidyWide (Transposed SlidyTall)) instance LayoutManager SlidyWide where pureLayout (SlidyWide w) = pureLayout w describeLayout _ = "Slidy wide windows, with balanced-position sliders" -- | Fixed number of \"main\" windows on the left; stack of windows on the right data HPairNStack = HPairNStack !Int deriving(Eq, Typeable) -- | @n@ windows on the left; stack of windows on the right. hPairNStack :: Int -> AnyLayoutManager hPairNStack n | n < 1 = error "Yi.Layout.hPairNStackLayout: n must be at least 1" | otherwise = AnyLayoutManager (HPairNStack n) instance LayoutManager HPairNStack where pureLayout (HPairNStack n) oldLayout (fmap singleWindow -> xs) | length xs <= n = runLayoutM $ evenStack Vertical xs | otherwise = runLayoutM $ case splitAt n xs of (ls, rs) -> pair Horizontal pos (evenStack Vertical ls) (evenStack Vertical rs) where pos = case oldLayout of Pair Horizontal pos' _ _ _ -> pos' _ -> 0.5 describeLayout (HPairNStack n) = show n ++ " windows on the left; remaining windows on the right" nextVariant (HPairNStack n) = HPairNStack (n+1) previousVariant (HPairNStack n) = HPairNStack (max (n-1) 1) newtype VPairNStack = VPairNStack (Transposed HPairNStack) deriving(Eq, Typeable) -- | Transposed version of 'hPairNStack'. vPairNStack :: Int -> AnyLayoutManager vPairNStack n = AnyLayoutManager (VPairNStack (Transposed (HPairNStack n))) instance LayoutManager VPairNStack where pureLayout (VPairNStack lm) = pureLayout lm previousVariant (VPairNStack lm) = VPairNStack (previousVariant lm) nextVariant (VPairNStack lm) = VPairNStack (nextVariant lm) describeLayout (VPairNStack (Transposed (HPairNStack n))) = show n ++ " windows on top; remaining windows beneath" ----------------------- Utils -- | A general bounding box data Rectangle = Rectangle { rectX, rectY, rectWidth, rectHeight :: !Double } deriving(Eq, Show) -- | Used by the vty frontend to draw vertical separators type HasNeighborWest = Bool layoutToRectangles :: HasNeighborWest -> Rectangle -> Layout a -> [(a, Rectangle, HasNeighborWest)] layoutToRectangles nb bounds (SingleWindow a) = [(a, bounds, nb)] layoutToRectangles nb bounds (Stack o ts) = handleStack o bounds ts' where ts' = if o == Vertical then setNbs nb ts else case ts of (l, s) : xs -> (l, s, nb) : setNbs True xs [] -> [] setNbs val = map (\(l, s) -> (l, s, val)) layoutToRectangles nb bounds (Pair o p _ a b) = handleStack o bounds [(a,p,nb), (b,1-p,nb')] where nb' = if o == Horizontal then True else nb handleStack :: Orientation -> Rectangle -> [(Layout a, RelativeSize, HasNeighborWest)] -> [(a, Rectangle, HasNeighborWest)] handleStack o bounds tiles = concat . snd . mapAccumL doTile startPos $ tiles where (totalSpace, startPos, mkBounds) = case o of Vertical -> (rectHeight bounds, rectY bounds, \pos size -> bounds { rectY = pos, rectHeight = size }) Horizontal -> (rectWidth bounds, rectX bounds, \pos size -> bounds { rectX = pos, rectWidth = size }) totalWeight' = sum . fmap (\(_, s, _) -> s) $ tiles totalWeight = if totalWeight' > 0 then totalWeight' else error "Yi.Layout: Stacks must have positive weights" spacePerWeight = totalSpace / totalWeight doTile pos (t, wt, nb) = (pos + wt * spacePerWeight, layoutToRectangles nb (mkBounds pos (wt * spacePerWeight)) t) ----------- Flipping things -- | Things with orientations which can be flipped class Transposable r where transpose :: r -> r instance Transposable Orientation where { transpose Horizontal = Vertical; transpose Vertical = Horizontal } instance Transposable (Layout a) where transpose (SingleWindow a) = SingleWindow a transpose (Stack o ws) = Stack (transpose o) (fmap (first transpose) ws) transpose (Pair o p r a b) = Pair (transpose o) p r (transpose a) (transpose b) -- | Same as 'lm', but with all 'Orientation's 'transpose'd. See 'slidyWide' for an example of its use. newtype Transposed lm = Transposed lm deriving(Eq, Typeable) instance LayoutManager lm => LayoutManager (Transposed lm) where pureLayout (Transposed lm) l ws = transpose (pureLayout lm (transpose l) ws) describeLayout (Transposed lm) = "Transposed version of: " ++ describeLayout lm nextVariant (Transposed lm) = Transposed (nextVariant lm) previousVariant (Transposed lm) = Transposed (previousVariant lm) -------------------- 'DividerRef' combinators -- $divRefCombinators -- It is tedious and error-prone for 'LayoutManager's to assign 'DividerRef's themselves. Better is to use these monadic smart constructors for 'Layout'. For example, the layout -- -- @'Pair' 'Horizontal' 0.5 0 ('Pair' 'Vertical' 0.5 1 ('SingleWindow' w1) ('SingleWindow' w2)) ('SingleWindow' w3)@ -- -- could be with the combinators below as -- -- @'runLayoutM' $ 'pair' 'Horizontal' 0.5 ('pair' 'Vertical' 0.5 ('singleWindow' w1) ('singleWindow' w2)) ('singleWindow' w3)@ -- -- These combinators do will also ensure strictness of the 'wins' field of 'Stack'. They also tidy up and do some error checking: length-1 stacks are removed (they are unnecessary); length-0 stacks raise errors. -- | A 'Layout a' wrapped in a state monad for tracking 'DividerRef's. This type is /not/ itself a monad, but should rather be thought of as a 'DividerRef'-free version of the 'Layout' type. newtype LayoutM a = LayoutM (Monad.State DividerRef (Layout a)) singleWindow :: a -> LayoutM a singleWindow a = LayoutM (pure (SingleWindow a)) pair :: Orientation -> DividerPosition -> LayoutM a -> LayoutM a -> LayoutM a pair o p (LayoutM l1) (LayoutM l2) = LayoutM $ do ref <- Monad.get Monad.put (ref+1) Pair o p ref <$> l1 <*> l2 stack :: Orientation -> [(LayoutM a, RelativeSize)] -> LayoutM a stack _ [] = error "Yi.Layout: Length-0 stack" stack _ [l] = fst l stack o ls = LayoutM (Stack o <$> mapM (\(LayoutM lm,rs) -> (,rs) <$> lm) ls) -- | Special case of 'stack' with all 'RelativeSize's equal. evenStack :: Orientation -> [LayoutM a] -> LayoutM a evenStack o ls = stack o (fmap (\l -> (l,1)) ls) runLayoutM :: LayoutM a -> Layout a runLayoutM (LayoutM l) = Monad.evalState l 0 yi-core-0.19.4/src/Yi/MiniBuffer.hs0000644000000000000000000004153107346545000015103 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Yi.Minibuffer -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Functions working with the minibuffer. module Yi.MiniBuffer ( spawnMinibufferE, withMinibufferFree, withMinibuffer , withMinibufferGen, withMinibufferFin, noHint , noPossibilities, mkCompleteFn, simpleComplete , infixComplete, infixComplete', anyModeByName , getAllModeNames, matchingBufferNames, anyModeByNameM , anyModeName, (:::)(..), LineNumber, RegexTag , FilePatternTag, ToKill, CommandArguments(..) , commentRegion, promptingForBuffer ) where import Lens.Micro.Platform (use, (%=)) import Control.Monad (forM, void, (<=<), (>=>)) import Data.Foldable (find, toList) import qualified Data.List.PointedList.Circular as PL (find, insertRight) import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Proxy (Proxy) import Data.String (IsString) import qualified Data.Text as T (Text, append, head, isInfixOf, null, pack, snoc, unpack, words) import Data.Typeable (Typeable) import System.CanonicalizePath (replaceShorthands) import Yi.Buffer import Yi.Completion import Yi.Config (modeTable) import Yi.Core (runAction) import Yi.Editor import Yi.History (historyFinishGen, historyMove, historyStartGen) import Yi.Keymap import Yi.Keymap.Keys import Yi.Monad (gets) import qualified Yi.Rope as R (YiString, fromText, toText) import Yi.String (commonTPrefix) import Yi.Style (defaultStyle) import Yi.Window (bufkey) -- | Prompts for a buffer name, turns it into a 'BufferRef' and passes -- it on to the handler function. Uses all known buffers for hinting. promptingForBuffer :: T.Text -- ^ Prompt -> (BufferRef -> YiM ()) -- ^ Handler -> ([BufferRef] -> [BufferRef] -> [BufferRef]) -- ^ Hint pre-processor. It takes the list of open -- buffers and a list of all buffers, and should -- spit out all the buffers to possibly hint, in -- the wanted order. Note the hinter uses name -- prefix for filtering regardless of what you do -- here. -> YiM () promptingForBuffer prompt act hh = do openBufs <- fmap bufkey . toList <$> use windowsA names <- withEditor $ do bs <- toList . fmap bkey <$> getBufferStack let choices = hh openBufs bs prefix <- gets commonNamePrefix forM choices $ \k -> gets (shortIdentString (length prefix) . findBufferWith k) withMinibufferFin prompt names (withEditor . getBufferWithName >=> act) -- | Prompts the user for comment syntax to use for the current mode. commentRegion :: YiM () commentRegion = withCurrentBuffer (gets $ withMode0 modeToggleCommentSelection) >>= \case Nothing -> withMinibufferFree "No comment syntax is defined. Use: " $ \cString -> withCurrentBuffer $ do let toggle = toggleCommentB (R.fromText cString) void toggle modifyMode $ \x -> x { modeToggleCommentSelection = Just toggle } Just b -> withCurrentBuffer b -- | Open a minibuffer window with the given prompt and keymap -- The third argument is an action to perform after the minibuffer -- is opened such as move to the first occurrence of a searched for -- string. If you don't need this just supply @return ()@ spawnMinibufferE :: T.Text -> KeymapEndo -> EditorM BufferRef spawnMinibufferE prompt kmMod = do b <- stringToNewBuffer (MemBuffer prompt) mempty -- Now create the minibuffer keymap and switch to the minibuffer window withGivenBuffer b $ modifyMode $ \m -> m { modeKeymap = \kms -> kms { topKeymap = kmMod (insertKeymap kms) } } -- The minibuffer window must not be moved from the position newWindowE places it! -- First: This way the minibuffer is just below the window that was in focus when -- the minibuffer was spawned. This clearly indicates what window is the target of -- some actions. Such as searching or the :w (save) command in the Vim keymap. -- Second: The users of the minibuffer expect the window and buffer that was in -- focus when the minibuffer was spawned to be in focus when the minibuffer is closed -- Given that window focus works as follows: -- - The new window is brought into focus. -- - The previous window in focus is to the left of the new window in the window -- set list. -- - When a window is deleted and is in focus then the window to the left is brought -- into focus. -- -- If the minibuffer is moved then when the minibuffer is deleted the window brought -- into focus may not be the window that spawned the minibuffer. w <- newWindowE True b windowsA %= PL.insertRight w return b -- | @withMinibuffer prompt completer act@: open a minibuffer with @prompt@. Once -- a string @s@ is obtained, run @act s@. @completer@ can be used to complete -- functions: it returns a list of possible matches. withMinibuffer :: T.Text -> (T.Text -> YiM [T.Text]) -> (T.Text -> YiM ()) -> YiM () withMinibuffer prompt getPossibilities = withMinibufferGen "" giveHint prompt completer (const $ return ()) where giveHint s = catMaybes . fmap (prefixMatch s) <$> getPossibilities s completer = simpleComplete getPossibilities -- | Makes a completion function. mkCompleteFn :: (T.Text -> (T.Text -> Maybe T.Text) -> [T.Text] -> EditorM T.Text) -- ^ List completion, such as 'completeInList'. -> (T.Text -> T.Text -> Maybe T.Text) -- ^ Matcher such as 'prefixMatch' -> (T.Text -> YiM [T.Text]) -- ^ Function to fetch possibilites for completion. -> T.Text -- ^ Input to try and complete against -> YiM T.Text mkCompleteFn completeInListFn match getPossibilities s = do possibles <- getPossibilities s withEditor $ completeInListFn s (match s) possibles simpleComplete :: (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text simpleComplete = mkCompleteFn completeInList prefixMatch infixComplete' :: Bool -> (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text infixComplete' caseSensitive = mkCompleteFn completeInList' $ containsMatch' caseSensitive infixComplete :: (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text infixComplete = infixComplete' True -- | Hint function that does nothing, for use with @'withMinibufferGen'@ noHint :: a -> YiM [a] noHint = const $ return [] noPossibilities :: String -> YiM [ String ] noPossibilities _s = return [] -- | @withMinibufferFree prompt act@: -- Simple version of @'withMinibufferGen'@ withMinibufferFree :: T.Text -> (T.Text -> YiM ()) -> YiM () withMinibufferFree prompt = withMinibufferGen "" noHint prompt return (const $ return ()) -- | @withMinibufferGen proposal getHint prompt completer onTyping act@: -- open a minibuffer with @prompt@, and initial content @proposal@. Once -- a string @s@ is obtained, run @act s@. @completer@ can be used to -- complete inputs by returning an incrementally better match, and -- getHint can give an immediate feedback to the user on the current -- input. -- -- @on Typing@ is an extra action which will fire with every user -- key-press and receives minibuffer contents. Use something like -- @const $ return ()@ if you don't need this. withMinibufferGen :: T.Text -> (T.Text -> YiM [T.Text]) -> T.Text -> (T.Text -> YiM T.Text) -> (T.Text -> YiM ()) -> (T.Text -> YiM ()) -> YiM () withMinibufferGen proposal getHint prompt completer onTyping act = do initialBuffer <- gets currentBuffer initialWindow <- use currentWindowA let innerAction :: YiM () -- ^ Read contents of current buffer (which should be the minibuffer), and -- apply it to the desired action closeMinibuffer = closeBufferAndWindowE >> windowsA %= fromJust . PL.find initialWindow showMatchings = showMatchingsOf . R.toText =<< withCurrentBuffer elemsB showMatchingsOf userInput = printStatus =<< withDefaultStyle <$> getHint userInput withDefaultStyle msg = (msg, defaultStyle) typing = onTyping . R.toText =<< withCurrentBuffer elemsB innerAction = do lineString <- withEditor $ do let bufToText = R.toText <$> withCurrentBuffer elemsB historyFinishGen prompt bufToText lineString <- bufToText closeMinibuffer switchToBufferE initialBuffer -- The above ensures that the action is performed on the buffer -- that originated the minibuffer. 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 `T.snoc` ' ') (\bindings -> rebindings <|| (bindings >> write showMatchings >> write typing)) withCurrentBuffer . replaceBufferContent . R.fromText $ replaceShorthands proposal -- | Open a minibuffer, given a finite number of suggestions. withMinibufferFin :: T.Text -> [T.Text] -> (T.Text -> YiM ()) -> YiM () withMinibufferFin prompt possibilities act = withMinibufferGen "" hinter prompt completer (const $ return ()) (act . best) where -- The function for returning the hints provided to the user underneath -- the input, basically all those that currently match. hinter s = return $ match s -- All those which currently match. match s = filter (s `T.isInfixOf`) possibilities -- The best match from the list of matches -- If the string matches completely then we take that -- otherwise we just take the first match. best s | s `elem` matches = s | null matches = s | otherwise = head matches where matches = match s -- We still want "TAB" to complete even though the user could just -- press return with an incomplete possibility. The reason is we -- may have for example two possibilities which share a long -- prefix and hence we wish to press tab to complete up to the -- point at which they differ. completer s = return $ fromMaybe s $ commonTPrefix $ catMaybes (infixUptoEndMatch s <$> possibilities) -- | TODO: decide whether we should be keeping 'T.Text' here or moving -- to 'YiString'. completionFunction :: (T.Text -> YiM T.Text) -> YiM () completionFunction f = do p <- withCurrentBuffer pointB let r = mkRegion 0 p text <- withCurrentBuffer $ readRegionB r compl <- R.fromText <$> f (R.toText text) -- it's important to do this before removing the text, so if the -- completion function raises an exception, we don't delete the -- buffer contents. withCurrentBuffer $ replaceRegionB r compl class Promptable a where getPromptedValue :: T.Text -> YiM a getPrompt :: Proxy a -> T.Text getMinibuffer :: Proxy a -> T.Text -> (T.Text -> YiM ()) -> YiM () getMinibuffer _ = withMinibufferFree doPrompt :: forall a. Promptable a => (a -> YiM ()) -> YiM () doPrompt act = getMinibuffer witness (getPrompt witness `T.append` ":") (act <=< getPromptedValue) where witness = undefined witness :: Proxy a instance Promptable String where getPromptedValue = return . T.unpack getPrompt _ = "String" instance Promptable Char where getPromptedValue x = if T.null x then error "Please supply a character." else return $ T.head x getPrompt _ = "Char" instance Promptable Int where getPromptedValue = return . read . T.unpack getPrompt _ = "Integer" instance Promptable T.Text where getPromptedValue = return getPrompt _ = "Text" instance Promptable R.YiString where getPromptedValue = return . R.fromText getPrompt _ = "YiString" -- helper functions: getPromptedValueList :: [(T.Text, a)] -> T.Text -> YiM a getPromptedValueList vs s = maybe (error "Invalid choice") return (lookup s vs) getMinibufferList :: [(T.Text, a)] -> Proxy a -> T.Text -> (T.Text -> YiM ()) -> YiM () getMinibufferList vs _ prompt = withMinibufferFin prompt (fmap fst vs) enumAll :: (Enum a, Bounded a, Show a) => [(T.Text, a)] enumAll = fmap (\v -> (T.pack $ show v, v)) [minBound..] instance Promptable Direction where getPromptedValue = getPromptedValueList enumAll getPrompt _ = "Direction" getMinibuffer = getMinibufferList enumAll textUnits :: [(T.Text, 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 -> T.Text anyModeName (AnyMode m) = modeName m -- TODO: Better name anyModeByNameM :: T.Text -> YiM (Maybe AnyMode) anyModeByNameM n = find ((n==) . anyModeName) . modeTable <$> askCfg anyModeByName :: T.Text -> YiM AnyMode anyModeByName n = anyModeByNameM n >>= \case Nothing -> fail $ "anyModeByName: no such mode: " ++ T.unpack n Just m -> return m getAllModeNames :: YiM [T.Text] 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 = getBufferWithNameOrCurrent getMinibuffer _ prompt act = do bufs <- matchingBufferNames withMinibufferFin prompt bufs act -- | Returns all the buffer names matchingBufferNames :: YiM [T.Text] matchingBufferNames = withEditor $ do p <- gets commonNamePrefix bs <- gets bufferSet return $ fmap (shortIdentString $ length p) bs instance (YiAction a x, Promptable r) => YiAction (r -> a) x where makeAction f = YiA $ doPrompt (runAction . makeAction . f) -- | Tag a type with a documentation 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 -- | What to prompt the user when asked this type? typeGetPrompt :: t -> T.Text 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 [T.Text] deriving (Show, Eq, Typeable) instance Promptable CommandArguments where getPromptedValue = return . CommandArguments . T.words getPrompt _ = "Command arguments" yi-core-0.19.4/src/Yi/Misc.hs0000644000000000000000000002761107346545000013753 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Misc -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Various high-level functions to further classify. module Yi.Misc ( getAppropriateFiles, getFolder, cd, pwd, matchingFileNames , rot13Char, placeMark, selectAll, adjIndent , promptFile , promptFileChangingHints, matchFile, completeFile , printFileInfoE, debugBufferContent ) where import Control.Concurrent import Control.Monad (filterM, (>=>), when, void) import Control.Monad.Base (liftBase) import Data.Char (chr, isAlpha, isLower, isUpper, ord) import Data.IORef import Data.List ((\\)) import Data.Maybe (isNothing) import qualified Data.Text as T (Text, append, concat, isPrefixOf, pack, stripPrefix, unpack) import System.CanonicalizePath (canonicalizePath, replaceShorthands, replaceShorthands) import System.Directory (doesDirectoryExist, getCurrentDirectory, getDirectoryContents, setCurrentDirectory) import System.Environment (lookupEnv) import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator, takeDirectory, takeFileName, ()) import System.FriendlyPath (expandTilda, isAbsolute') import Yi.Buffer import Yi.Completion (completeInList') import Yi.Core (onYiVar) import Yi.Editor (EditorM, printMsg, withCurrentBuffer, withGivenBuffer, findBuffer) import Yi.Keymap (YiM, makeAction, YiAction) import Yi.MiniBuffer (mkCompleteFn, withMinibufferGen, promptingForBuffer) import Yi.Monad (gets) import qualified Yi.Rope as R (fromText, YiString) import Yi.Types (IsRefreshNeeded(..), Yi(..)) import Yi.Utils (io) -- | Given a possible starting path (which if not given defaults to -- the current directory) and a fragment of a path we find all files -- within the given (or current) directory which can complete the -- given path fragment. We return a pair of both directory plus the -- filenames on their own that is without their directories. The -- reason for this is that if we return all of the filenames then we -- get a 'hint' which is way too long to be particularly useful. getAppropriateFiles :: Maybe T.Text -> T.Text -> YiM (T.Text, [ T.Text ]) getAppropriateFiles start s' = do curDir <- case start of Nothing -> do bufferPath <- withCurrentBuffer $ gets file liftBase $ getFolder bufferPath Just path -> return $ T.unpack path let s = T.unpack $ replaceShorthands s' sDir = if hasTrailingPathSeparator s then s else takeDirectory s searchDir | null sDir = curDir | isAbsolute' sDir = sDir | otherwise = curDir sDir searchDir' <- liftBase $ expandTilda searchDir let fixTrailingPathSeparator f = do isDir <- doesDirectoryExist (searchDir' f) return . T.pack $ if isDir then addTrailingPathSeparator f else f files <- liftBase $ getDirectoryContents searchDir' -- Remove the two standard current-dir and parent-dir as we do not -- need to complete or hint about these as they are known by users. let files' = files \\ [ ".", ".." ] fs <- liftBase $ mapM fixTrailingPathSeparator files' let matching = filter (T.isPrefixOf . T.pack $ takeFileName s) fs return (T.pack sDir, matching) -- | Given a path, trim the file name bit if it exists. If no path -- given, return current directory. getFolder :: Maybe String -> IO String getFolder Nothing = getCurrentDirectory getFolder (Just path) = do isDir <- doesDirectoryExist path let dir = if isDir then path else takeDirectory path if null dir then getCurrentDirectory else return dir -- | Given a possible path and a prefix, return matching file names. matchingFileNames :: Maybe T.Text -> T.Text -> YiM [T.Text] matchingFileNames start s = do (sDir, files) <- getAppropriateFiles start s -- There is one common case when we don't need to prepend @sDir@ to @files@: -- -- Suppose user just wants to edit a file "foobar" in current directory -- and inputs ":e foo" -- -- @sDir@ in this case equals to "." and "foo" would not be -- a prefix of ("." "foobar"), resulting in a failed completion -- -- However, if user inputs ":e ./foo", we need to prepend @sDir@ to @files@ let results = if isNothing start && sDir == "." && not ("./" `T.isPrefixOf` s) then files else fmap (T.pack . (T.unpack sDir ) . T.unpack) files return results -- | Place mark at current point. If there's an existing mark at point -- already, deactivate mark. placeMark :: BufferM () placeMark = (==) <$> pointB <*> getSelectionMarkPointB >>= \case True -> setVisibleSelection False False -> setVisibleSelection True >> pointB >>= setSelectionMarkPointB -- | Select the contents of the whole buffer selectAll :: BufferM () selectAll = botB >> placeMark >> topB >> setVisibleSelection True -- | A simple wrapper to adjust the current indentation using -- the mode specific indentation function but according to the -- given indent behaviour. adjIndent :: IndentBehaviour -> BufferM () adjIndent ib = withSyntaxB' (\m s -> modeIndent m s ib) -- | Generic emacs style prompt file action. Takes a @prompt@ and a continuation -- @act@ and prompts the user with file hints. promptFile :: T.Text -> (T.Text -> YiM ()) -> YiM () promptFile prompt act = promptFileChangingHints prompt (const return) act -- | As 'promptFile' but additionally allows the caller to transform -- the list of hints arbitrarily, such as only showing directories. promptFileChangingHints :: T.Text -- ^ Prompt -> (T.Text -> [T.Text] -> YiM [T.Text]) -- ^ Hint transformer: current path, generated hints -> (T.Text -> YiM ()) -- ^ Action over choice -> YiM () promptFileChangingHints prompt ht act = do maybePath <- withCurrentBuffer $ gets file startPath <- T.pack . addTrailingPathSeparator <$> liftBase (canonicalizePath =<< getFolder maybePath) -- TODO: Just call withMinibuffer withMinibufferGen startPath (\x -> findFileHint startPath x >>= ht x) prompt (completeFile startPath) showCanon (act . replaceShorthands) where showCanon = withCurrentBuffer . replaceBufferContent . R.fromText . replaceShorthands matchFile :: T.Text -> T.Text -> Maybe T.Text matchFile path proposedCompletion = let realPath = replaceShorthands path in T.append path <$> T.stripPrefix realPath proposedCompletion completeFile :: T.Text -> T.Text -> YiM T.Text completeFile startPath = mkCompleteFn completeInList' matchFile $ matchingFileNames (Just startPath) -- | For use as the hint when opening a file using the minibuffer. We -- essentially return all the files in the given directory which have -- the given prefix. findFileHint :: T.Text -> T.Text -> YiM [T.Text] findFileHint startPath s = snd <$> getAppropriateFiles (Just startPath) s onCharLetterCode :: (Int -> Int) -> Char -> Char onCharLetterCode f c | isAlpha c = chr (f (ord c - a) `mod` 26 + a) | otherwise = c where a | isUpper c = ord 'A' | isLower c = ord 'a' | otherwise = undefined -- | Like @M-x cd@, it changes the current working directory. Mighty -- useful when we don't start Yi from the project directory or want to -- switch projects, as many tools only use the current working -- directory. cd :: YiM () cd = promptFileChangingHints "switch directory to:" dirs $ \path -> io $ getFolder (Just $ T.unpack path) >>= clean . T.pack >>= System.Directory.setCurrentDirectory . addTrailingPathSeparator where replaceHome p@('~':'/':xs) = lookupEnv "HOME" >>= return . \case Nothing -> p Just h -> h xs replaceHome p = return p clean = replaceHome . T.unpack . replaceShorthands >=> canonicalizePath x y = T.pack $ takeDirectory (T.unpack x) T.unpack y dirs :: T.Text -> [T.Text] -> YiM [T.Text] dirs x xs = do xsc <- io $ mapM (\y -> (,y) <$> clean (x y)) xs filterM (io . doesDirectoryExist . fst) xsc >>= return . map snd -- | Shows current working directory. Also see 'cd'. pwd :: YiM () pwd = io getCurrentDirectory >>= printMsg . T.pack rot13Char :: Char -> Char rot13Char = onCharLetterCode (+13) printFileInfoE :: EditorM () printFileInfoE = printMsg . showBufInfo =<< withCurrentBuffer bufInfoB where showBufInfo :: BufferFileInfo -> T.Text showBufInfo bufInfo = T.concat [ T.pack $ bufInfoFileName bufInfo , " Line " , T.pack . show $ bufInfoLineNo bufInfo , " [" , bufInfoPercent bufInfo , "]" ] -- | Runs a 'YiM' action in a separate thread. -- -- Notes: -- -- * It seems to work but I don't know why -- -- * Maybe deadlocks? -- -- * If you're outputting into the Yi window, you should really limit -- the rate at which you do so: for example, the Pango front-end will -- quite happily segfault/double-free if you output too fast. -- -- I am exporting this for those adventurous to play with but I have -- only discovered how to do this a night before the release so it's -- rather experimental. A simple function that prints a message once a -- second, 5 times, could be written like this: -- -- @ -- printer :: YiM ThreadId -- printer = do -- mv <- io $ newMVar (0 :: Int) -- forkAction (suicide mv) MustRefresh $ do -- c <- io $ do -- modifyMVar_ mv (return . succ) -- tryReadMVar mv -- case c of -- Nothing -> printMsg "messaging unknown time" -- Just x -> printMsg $ "message #" <> showT x -- where -- suicide mv = tryReadMVar mv >>= \case -- Just i | i >= 5 -> return True -- _ -> threadDelay 1000000 >> return False -- @ forkAction :: (YiAction a x, Show x) => IO Bool -- ^ runs after we insert the action: this may be a -- thread delay or a thread suicide or whatever else; -- when delay returns False, that's our signal to -- terminate the thread. -> IsRefreshNeeded -- ^ should we refresh after each action -> a -- ^ The action to actually run -> YiM ThreadId forkAction delay ref ym = onYiVar $ \yi yv -> do let loop = do yiOutput yi ref [makeAction ym] delay >>= \b -> when b loop t <- forkIO loop return (yv, t) -- | Prints out the rope of the current buffer as-is to stdout. -- -- The only way to stop it is to close the buffer in question which -- should free up the 'BufferRef'. debugBufferContent :: YiM () debugBufferContent = promptingForBuffer "buffer to trace:" debugBufferContentUsing (\_ x -> x) debugBufferContentUsing :: BufferRef -> YiM () debugBufferContentUsing b = do mv <- io $ newIORef mempty keepGoing <- io $ newIORef True let delay = threadDelay 100000 >> readIORef keepGoing void . forkAction delay NoNeedToRefresh $ findBuffer b >>= \case Nothing -> io $ writeIORef keepGoing True Just _ -> do ns <- withGivenBuffer b elemsB :: YiM R.YiString io $ readIORef mv >>= \c -> when (c /= ns) (print ns >> void (writeIORef mv ns))yi-core-0.19.4/src/Yi/Mode/0000755000000000000000000000000007346545000013401 5ustar0000000000000000yi-core-0.19.4/src/Yi/Mode/Common.hs0000644000000000000000000001466107346545000015175 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Mode.Common -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Common functions used by modes. module Yi.Mode.Common (TokenBasedMode, fundamentalMode, anyExtension, extensionOrContentsMatch, linearSyntaxMode, hookModes, applyModeHooks, lookupMode, styleMode, extensionMatches, shebangParser ) where import Lens.Micro.Platform ((%~), (&), (.~), (^.)) import Control.Applicative ((<|>)) import Control.Monad (void) import qualified Data.Attoparsec.Text as P import Data.Maybe (fromMaybe) import System.FilePath (takeExtension) import Yi.Buffer import qualified Yi.IncrementalParse as IncrParser (scanner) import Yi.Keymap (YiM) import Yi.Lexer.Alex import Yi.MiniBuffer (anyModeByNameM) import qualified Yi.Rope as R (YiString, toText) import Yi.Search (makeSimpleSearch) import Yi.Style (StyleName) import Yi.Syntax (ExtHL (ExtHL)) import Yi.Syntax.Driver (mkHighlighter) import Yi.Syntax.OnlineTree (Tree, manyToks) import Yi.Syntax.Tree (tokenBasedStrokes) type TokenBasedMode tok = Mode (Tree (Tok tok)) -- TODO: Move this mode to it's own module -- | The only built in mode of yi fundamentalMode :: Mode syntax fundamentalMode = emptyMode { modeName = "fundamental" , modeApplies = modeAlwaysApplies , modeIndent = const autoIndentB , modePrettify = const fillParagraph , modeGotoDeclaration = do currentPoint <- pointB currentWord <- readCurrentWordB currentWordBeginningPoint <- regionStart <$> regionOfB unitWord _ <- gotoLn 0 word <- return $ makeSimpleSearch currentWord searchResults <- regexB Forward word case searchResults of (declarationRegion : _) -> do searchPoint <- return $ regionStart declarationRegion if currentWordBeginningPoint /= searchPoint then moveTo searchPoint else moveTo currentPoint [] -> moveTo currentPoint } -- | Creates a 'TokenBasedMode' from a 'Lexer' and a function that -- turns tokens into 'StyleName'. linearSyntaxMode' :: Show (l s) => Lexer l s (Tok t) i -> (t -> StyleName) -> TokenBasedMode t linearSyntaxMode' scanToken tts = fundamentalMode & modeHLA .~ ExtHL (mkHighlighter $ IncrParser.scanner manyToks . lexer) & modeGetStrokesA .~ tokenBasedStrokes tokenToStroke where tokenToStroke = fmap tts . tokToSpan lexer = lexScanner scanToken -- | Specialised version of 'linearSyntaxMode'' for the common case, -- wrapping up into a 'Lexer' with 'commonLexer'. linearSyntaxMode :: Show s => s -- ^ Starting state -> TokenLexer AlexState s (Tok t) AlexInput -> (t -> StyleName) -> TokenBasedMode t linearSyntaxMode initSt scanToken = linearSyntaxMode' (commonLexer scanToken initSt) styleMode :: Show (l s) => StyleLexer l s t i -> TokenBasedMode t styleMode l = linearSyntaxMode' (l ^. styleLexer) (l ^. tokenToStyle) -- | Determines if the file's extension is one of the extensions in the list. extensionMatches :: [String] -> FilePath -> Bool extensionMatches extensions fileName = extension `elem` extensions' where extension = takeExtension fileName extensions' = ['.' : ext | ext <- extensions] -- | When applied to an extensions list, creates a 'Mode.modeApplies' function. anyExtension :: [String] -- ^ List of extensions -> FilePath -- ^ Path to compare against -> a -- ^ File contents. Currently unused but see -- 'extensionOrContentsMatch'. -> Bool anyExtension extensions fileName _contents = extensionMatches extensions fileName -- | When applied to an extensions list and regular expression pattern, creates -- a 'Mode.modeApplies' function. extensionOrContentsMatch :: [String] -> P.Parser () -> FilePath -> R.YiString -> Bool extensionOrContentsMatch extensions parser fileName contents = extensionMatches extensions fileName || m where m = case P.parseOnly parser $ R.toText contents of Left _ -> False Right _ -> True {- | Generate a parser for shebang patterns the generated parser will match only if the shebang is at the start of a line ==== __Examples__ > shebangParser "runhaskell" generates a parser that matches "#!\/usr\/bin\/env runhaskell\\n" (but also "djsjfaj\\n\\n\\n\\r\\n#! \/usr\/bin\/env runhaskell \\ndkasfkda\\n\\r\\nkasfaj") __Note:__ You can get @("runhaskell" :: Parser String)@ by using the OverloadedStrings extension > shebangParser "python" generates a parser that matches "#!\/usr\/bin\/env python\\n" __Note:__ it doesn't match "#!\/usr\/bin\/env python2\\n" (that's why the newline is required) It is also possible to use more complex parsers: > shebangParser ("python" *> ("2" <|> "3" <|> "")) generates a parser that matches any of: * "#!\/usr\/bin\/env python\\n" * "#!\/usr\/bin\/env python2\\n" * "#!\/usr\/bin\/env python3\\n" -} shebangParser :: P.Parser a -> P.Parser () shebangParser p = void p' where p' = "#!" *> P.skipWhile (== ' ') *> "/usr/bin/env " *> P.skipWhile (== ' ') *> p *> P.skipWhile (== ' ') *> P.endOfLine <|> P.skip (const True) *> P.skipWhile (not . P.isEndOfLine) *> P.skipWhile P.isEndOfLine *> p' -- | Adds a hook to all matching hooks in a list hookModes :: (AnyMode -> Bool) -> BufferM () -> [AnyMode] -> [AnyMode] hookModes p h = map $ \am@(AnyMode m) -> if p am then AnyMode (m & modeOnLoadA %~ (>> h)) else am -- | Apply a list of mode hooks to a list of AnyModes applyModeHooks :: [(AnyMode -> Bool, BufferM ())] -> [AnyMode] -> [AnyMode] applyModeHooks hs ms = flip map ms $ \am -> case filter (($ am) . fst) hs of [] -> am ls -> onMode (modeOnLoadA %~ \x -> foldr ((>>) . snd) x ls) am -- | Check whether a mode of the same name is already in modeTable and -- returns the original mode, if it isn't the case. lookupMode :: AnyMode -> YiM AnyMode lookupMode am@(AnyMode m) = fromMaybe am <$> anyModeByNameM (modeName m) yi-core-0.19.4/src/Yi/Mode/Compilation.hs0000644000000000000000000000324107346545000016213 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Mode.Compilation -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- A 'Mode' for working with buffers showing the results of compilations. module Yi.Mode.Compilation where import Lens.Micro.Platform ((%~), (&), (.~)) import Data.Text () import Yi.Buffer import Yi.Core (withSyntax) import Yi.Editor (shiftOtherWindow, withCurrentBuffer) import Yi.File (openingNewFile) import Yi.Keymap (Action (YiA), topKeymapA) import Yi.Keymap.Keys (Key (KEnter), spec, (<||), (?>>!)) import Yi.Lexer.Alex (Posn (..), Tok (..)) import qualified Yi.Lexer.Compilation as Compilation (Token (Report), lexer) import Yi.Mode.Common (TokenBasedMode, styleMode) import qualified Yi.Syntax.OnlineTree as OnlineTree (tokAtOrBefore) mode :: TokenBasedMode Compilation.Token mode = styleMode Compilation.lexer & modeAppliesA .~ modeNeverApplies & modeNameA .~ "compilation" & modeKeymapA .~ topKeymapA %~ ((spec KEnter ?>>! withSyntax modeFollow) <||) & modeFollowA .~ YiA . follow where follow errs = withCurrentBuffer pointB >>= \point -> case OnlineTree.tokAtOrBefore point errs of Just t@Tok {tokT = Compilation.Report filename line col _} -> do withCurrentBuffer . moveTo . posnOfs $ tokPosn t shiftOtherWindow openingNewFile filename $ gotoLn line >> rightN col _ -> return () yi-core-0.19.4/src/Yi/Mode/Interactive.hs0000644000000000000000000001077307346545000016222 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Mode.Interactive -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Collection of 'Mode's for working with Haskell. module Yi.Mode.Interactive where import Control.Concurrent (threadDelay) import Lens.Micro.Platform (use, (%~), (.=)) import Data.Monoid ((<>)) import qualified Data.Text as T (Text) import Yi.Buffer import Yi.Core (sendToProcess, startSubprocess, withSyntax) import Yi.Editor import Yi.History (historyFinishGen, historyMoveGen, historyStartGen) import Yi.Keymap (YiM, topKeymapA) import Yi.Keymap.Keys (Key (KEnter, KHome), char, choice, meta, spec, (<||), (?>>!)) import Yi.Lexer.Alex (Tok) import Yi.Lexer.Compilation (Token) import qualified Yi.Mode.Compilation as Compilation (mode) import Yi.Mode.Common (lookupMode) import Yi.Monad (gets) import qualified Yi.Rope as R (YiString, fromText, toString, toText) import qualified Yi.Syntax.OnlineTree as OnlineTree (Tree) import Yi.Utils (io) mode :: Mode (OnlineTree.Tree (Tok Token)) mode = Compilation.mode { modeApplies = modeNeverApplies, modeName = "interactive", modeKeymap = topKeymapA %~ (<||) (choice [spec KHome ?>>! moveToSol, spec KEnter ?>>! do eof <- withCurrentBuffer atLastLine if eof then feedCommand else withSyntax modeFollow, meta (char 'p') ?>>! interactHistoryMove 1, meta (char 'n') ?>>! interactHistoryMove (-1) ]) } interactId :: T.Text interactId = "Interact" -- | TODO: we're just converting back and forth here, 'historyMoveGen' -- and friends need to migrate to YiString it seems. interactHistoryMove :: Int -> EditorM () interactHistoryMove delta = historyMoveGen interactId delta (R.toText <$> withCurrentBuffer getInput) >>= inp where inp = withCurrentBuffer . setInput . R.fromText interactHistoryFinish :: EditorM () interactHistoryFinish = historyFinishGen interactId (R.toText <$> withCurrentBuffer getInput) interactHistoryStart :: EditorM () interactHistoryStart = historyStartGen interactId getInputRegion :: BufferM Region getInputRegion = do mo <- getMarkB (Just "StdOUT") p <- pointAt botB q <- use $ markPointA mo return $ mkRegion p q getInput :: BufferM R.YiString getInput = readRegionB =<< getInputRegion setInput :: R.YiString -> BufferM () setInput val = flip replaceRegionB val =<< getInputRegion -- | Open a new buffer for interaction with a process. spawnProcess :: String -> [String] -> YiM BufferRef spawnProcess = spawnProcessMode mode -- | open a new buffer for interaction with a process, using any -- interactive-derived mode spawnProcessMode :: Mode syntax -> FilePath -> [String] -> YiM BufferRef spawnProcessMode interMode cmd args = do b <- startSubprocess cmd args (const $ return ()) withEditor interactHistoryStart mode' <- lookupMode $ AnyMode interMode withCurrentBuffer $ do m1 <- getMarkB (Just "StdERR") m2 <- getMarkB (Just "StdOUT") modifyMarkB m1 (\v -> v {markGravity = Backward}) modifyMarkB m2 (\v -> v {markGravity = Backward}) setAnyMode mode' return b -- | Send the type command to the process feedCommand :: YiM () feedCommand = do b <- gets currentBuffer withEditor interactHistoryFinish cmd <- withCurrentBuffer $ do botB newlineB me <- getMarkB (Just "StdERR") mo <- getMarkB (Just "StdOUT") p <- pointB q <- use $ markPointA mo cmd <- readRegionB $ mkRegion p q markPointA me .= p markPointA mo .= p return $ R.toString cmd withEditor interactHistoryStart sendToProcess b cmd -- | Send command, receive reply queryReply :: BufferRef -> String -> YiM R.YiString queryReply buf cmd = do start <- withGivenBuffer buf (botB >> pointB) sendToProcess buf (cmd <> "\n") io $ threadDelay 50000 -- Hack to let ghci finish writing its output. withGivenBuffer buf $ do botB moveToSol leftB -- There is probably a much better way to do this moving around, but it works end <- pointB result <- readRegionB (mkRegion start end) botB return result yi-core-0.19.4/src/Yi/Monad.hs0000644000000000000000000000262507346545000014114 0ustar0000000000000000module Yi.Monad ( assign, gets, getsAndModify, maybeM, repeatUntilM, uses, whenM, with, ) where import Control.Monad (when) import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Reader (MonadReader, ask) import Control.Monad.State (MonadState, get, gets, put) import Lens.Micro.Platform (Getting, ASetter, (.=), use) -- | Combination of the Control.Monad.State 'modify' and 'gets' getsAndModify :: MonadState s m => (s -> (s,a)) -> m a getsAndModify f = do e <- get let (e',result) = f e put e' return result with :: (MonadReader r m, MonadBase b m) => (r -> a) -> (a -> b c) -> m c with f g = do yi <- ask liftBase $ g (f yi) whenM :: Monad m => m Bool -> m () -> m () whenM mtest ma = mtest >>= flip when ma maybeM :: Monad m => (x -> m ()) -> Maybe x -> m () maybeM _ Nothing = return () maybeM f (Just x) = f x -- | Rerun the monad until the boolean result is false, collecting list of results. repeatUntilM :: Monad m => m (Bool,a) -> m [a] repeatUntilM m = do (proceed,x) <- m if proceed then (do xs <- repeatUntilM m return (x:xs)) else return [x] assign :: MonadState s m => ASetter s s a b -> b -> m () assign = (.=) uses :: MonadState s m => Getting a s a -> (a -> b) -> m b uses l f = f <$> use l yi-core-0.19.4/src/Yi/Paths.hs0000644000000000000000000000575607346545000014145 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Yi.Paths ( getEvaluatorContextFilename , getConfigFilename , getConfigModules , getPersistentStateFilename , getConfigDir , getConfigPath , getCustomConfigPath , getDataPath ) where import Control.Monad.Base (MonadBase, liftBase) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getAppUserDataDirectory) import qualified System.Environment.XDG.BaseDir as XDG (getUserConfigDir, getUserDataDir) import System.FilePath (()) appUserDataCond ::(MonadBase IO m) => (String -> IO FilePath) -> m FilePath appUserDataCond dirQuery = liftBase $ do oldDir <- getAppUserDataDirectory "yi" newDir <- dirQuery "yi" oldDirExists <- doesDirectoryExist oldDir newDirExists <- doesDirectoryExist newDir if newDirExists -- overrides old-style then return newDir else if oldDirExists -- old-style exists, use it then return oldDir else do createDirectoryIfMissing True newDir -- none exists, use new style, but create it return newDir getConfigDir ::(MonadBase IO m) => m FilePath getConfigDir = appUserDataCond XDG.getUserConfigDir getDataDir ::(MonadBase IO m) => m FilePath getDataDir = appUserDataCond XDG.getUserDataDir -- | Given a path relative to application data directory, -- this function finds a path to a given data file. getDataPath :: (MonadBase IO m) => FilePath -> m FilePath getDataPath fp = fmap ( fp) getDataDir -- | Given a path relative to application configuration directory, -- this function finds a path to a given configuration file. getConfigPath :: MonadBase IO m => FilePath -> m FilePath getConfigPath = getCustomConfigPath getConfigDir -- | Given an action that retrieves config path, and a path relative to it, -- this function joins the two together to create a config file path. getCustomConfigPath :: MonadBase IO m => m FilePath -> FilePath -> m FilePath getCustomConfigPath cd fp = ( fp) `fmap` cd -- Note: Dyre also uses XDG cache dir - that would be: --getCachePath = getPathHelper XDG.getUserCacheDirectory -- Below are all points that are used in Yi code (to keep it clean.) getEvaluatorContextFilename, getConfigFilename, getConfigModules, getPersistentStateFilename :: (MonadBase IO m) => m FilePath -- | Get Yi master configuration script. getConfigFilename = getConfigPath "yi.hs" getConfigModules = getConfigPath "modules" -- | Get path to Yi history that stores state between runs. getPersistentStateFilename = getDataPath "history" -- | Get path to environment file that defines namespace used by Yi -- command evaluator. getEvaluatorContextFilename = getConfigPath $ "local" "Env.hs" yi-core-0.19.4/src/Yi/PersistentState.hs0000644000000000000000000001222207346545000016211 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Haskell2010 #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | This module implements persistence across different Yi runs. -- It includes minibuffer command history, marks etc. -- Warning: Current version will _not_ check whether two or more instances -- of Yi are run at the same time. module Yi.PersistentState(loadPersistentState, savePersistentState, maxHistoryEntries, persistentSearch) where import GHC.Generics (Generic) import Control.Exc (ignoringException) import Lens.Micro.Platform ((.=), makeLenses, use) import Control.Monad (when) import Data.Binary (Binary, decodeFile, encodeFile) import Data.Default (Default, def) import qualified Data.Map as M (map) import Data.Typeable (Typeable) import System.Directory (doesFileExist) import Yi.Config.Simple.Types (Field, customVariable) import Yi.Editor import Yi.History (Histories (..), History (..)) import Yi.Keymap (YiM) import Yi.KillRing (Killring (..)) import Yi.Paths (getPersistentStateFilename) import Yi.Regex (SearchExp (..)) import Yi.Search.Internal (getRegexE, setRegexE) import Yi.Types (YiConfigVariable) import Yi.Utils (io) data PersistentState = PersistentState { histories :: !Histories , aKillring :: !Killring , aCurrentRegex :: Maybe SearchExp } deriving (Generic) instance Binary PersistentState newtype MaxHistoryEntries = MaxHistoryEntries { _unMaxHistoryEntries :: Int } deriving(Typeable, Binary) instance Default MaxHistoryEntries where def = MaxHistoryEntries 1000 instance YiConfigVariable MaxHistoryEntries makeLenses ''MaxHistoryEntries maxHistoryEntries :: Field Int maxHistoryEntries = customVariable . unMaxHistoryEntries newtype PersistentSearch = PersistentSearch { _unPersistentSearch :: Bool } deriving(Typeable, Binary) instance Default PersistentSearch where def = PersistentSearch True instance YiConfigVariable PersistentSearch makeLenses ''PersistentSearch persistentSearch :: Field Bool persistentSearch = customVariable . unPersistentSearch -- | Trims per-command histories to contain at most N completions each. trimHistories :: Int -> Histories -> Histories trimHistories maxHistory (Histories m) = Histories $ M.map trimH m where trimH (History cur content prefix) = History cur (trim content) prefix trim content = drop (max 0 (length content - maxHistory)) content -- | Here is a persistent history saving part. -- We assume each command is a single line. -- To add new components, one has to: -- -- * add new field in @PersistentState@ structure, -- * add write and read parts in @loadPersistentState@/@savePersistentState@, -- * add a trimming code in @savePersistentState@ to prevent blowing up -- of save file. savePersistentState :: YiM () savePersistentState = do MaxHistoryEntries histLimit <- withEditor askConfigVariableA pStateFilename <- getPersistentStateFilename (hist :: Histories) <- withEditor getEditorDyn kr <- withEditor $ use killringA curRe <- withEditor getRegexE let pState = PersistentState { histories = trimHistories histLimit hist , aKillring = kr -- trimmed during normal operation , aCurrentRegex = curRe -- just a single value -> no need to trim } io $ encodeFile pStateFilename pState -- | Reads and decodes a persistent state in both strict, and exception robust -- way. readPersistentState :: YiM (Maybe PersistentState) readPersistentState = do pStateFilename <- getPersistentStateFilename pStateExists <- io $ doesFileExist pStateFilename if not pStateExists then return Nothing else io $ ignoringException $ strictDecoder pStateFilename where strictDecoder filename = do (state :: PersistentState) <- decodeFile filename state `seq` return (Just state) -- | Loads a persistent state, and sets Yi state variables accordingly. loadPersistentState :: YiM () loadPersistentState = do maybePState <- readPersistentState case maybePState of Nothing -> return () Just pState -> do putEditorDyn $ histories pState (.=) killringA $ aKillring pState PersistentSearch keepSearch <- askConfigVariableA when keepSearch . withEditor $ maybe (return ()) setRegexE $ aCurrentRegex pState yi-core-0.19.4/src/Yi/Process.hs0000644000000000000000000001042107346545000014465 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Yi.Process (runProgCommand, runShellCommand, shellFileName, createSubprocess, readAvailable, SubprocessInfo(..), SubprocessId) where import Control.Exc (orException) import qualified Data.ListLike as L (empty) import Foreign.C.String (peekCStringLen) import Foreign.Marshal.Alloc (allocaBytes) import System.Directory (findExecutable) import System.Environment (getEnv) import System.Exit (ExitCode (ExitFailure)) import System.IO (BufferMode (NoBuffering), Handle, hSetBuffering, hGetBufNonBlocking) import System.Process (ProcessHandle, runProcess) import System.Process.ListLike (ListLikeProcessIO, readProcessWithExitCode) import Yi.Buffer.Basic (BufferRef) import Yi.Monad (repeatUntilM) #ifdef mingw32_HOST_OS import System.Process (runInteractiveProcess) #else import System.Posix.IO (createPipe, fdToHandle) #endif runProgCommand :: ListLikeProcessIO a c => String -> [String] -> IO (ExitCode, a, a) runProgCommand prog args = do loc <- findExecutable prog case loc of Nothing -> return (ExitFailure 1, L.empty, L.empty) Just fp -> readProcessWithExitCode fp args L.empty ------------------------------------------------------------------------ -- | Run a command using the system shell, returning stdout, stderr and exit code shellFileName :: IO String shellFileName = orException (getEnv "SHELL") (return "/bin/sh") shellCommandSwitch :: String shellCommandSwitch = "-c" runShellCommand :: ListLikeProcessIO a c => String -> IO (ExitCode, a, a) runShellCommand cmd = do sh <- shellFileName readProcessWithExitCode sh [shellCommandSwitch, cmd] L.empty -------------------------------------------------------------------------------- -- Subprocess support (ie. async processes whose output goes to a buffer) type SubprocessId = Integer data SubprocessInfo = SubprocessInfo { procCmd :: FilePath, procArgs :: [String], procHandle :: ProcessHandle, hIn :: Handle, hOut :: Handle, hErr :: Handle, bufRef :: BufferRef, separateStdErr :: Bool } {- Simon Marlow said this: It turns out to be dead easy to bind stderr and stdout to the same pipe. After a couple of minor tweaks the following now works: createProcess (proc cmd args){ std_out = CreatePipe, std_err = UseHandle stdout } Therefore it should be possible to simplify the following greatly with the new process package. -} createSubprocess :: FilePath -> [String] -> BufferRef -> IO SubprocessInfo createSubprocess cmd args bufref = do #ifdef mingw32_HOST_OS (inp,out,err,handle) <- runInteractiveProcess cmd args Nothing Nothing let separate = True #else (inpReadFd,inpWriteFd) <- System.Posix.IO.createPipe (outReadFd,outWriteFd) <- System.Posix.IO.createPipe [inpRead,inpWrite,outRead,outWrite] <- mapM fdToHandle [inpReadFd,inpWriteFd,outReadFd,outWriteFd] handle <- runProcess cmd args Nothing Nothing (Just inpRead) (Just outWrite) (Just outWrite) let inp = inpWrite out = outRead err = outRead separate = False #endif hSetBuffering inp NoBuffering hSetBuffering out NoBuffering hSetBuffering err NoBuffering return SubprocessInfo { procCmd=cmd, procArgs=args, procHandle=handle, hIn=inp, hOut=out, hErr=err, bufRef=bufref, separateStdErr=separate } -- Read as much as possible from handle without blocking readAvailable :: Handle -> IO String readAvailable handle = fmap concat $ repeatUntilM $ readChunk handle -- Read a chunk from a handle, bool indicates if there is potentially more data available readChunk :: Handle -> IO (Bool, String) readChunk handle = do let bufferSize = 1024 allocaBytes bufferSize $ \buffer -> do bytesRead <- hGetBufNonBlocking handle buffer bufferSize s <- peekCStringLen (buffer,bytesRead) let mightHaveMore = bytesRead == bufferSize return (mightHaveMore, s) yi-core-0.19.4/src/Yi/Rectangle.hs0000644000000000000000000000501407346545000014755 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Rectangle -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- emacs-style rectangle manipulation functions. module Yi.Rectangle where import Control.Monad (forM_) import Data.List (sort, transpose) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, concat, justifyLeft, length) import Yi.Buffer import Yi.Editor (EditorM, getRegE, setRegE, withCurrentBuffer) import qualified Yi.Rope as R import Yi.String (lines', mapLines, unlines') -- | Get the selected region as a rectangle. -- Returns the region extended to lines, plus the start and end columns of the rectangle. getRectangle :: BufferM (Region, Int, Int) getRectangle = do r <- getSelectRegionB extR <- unitWiseRegion Line r [lowCol,highCol] <- sort <$> mapM colOf [regionStart r, regionEnd r] return (extR, lowCol, highCol) -- | Split text at the boundaries given multiSplit :: [Int] -> R.YiString -> [R.YiString] multiSplit [] l = [l] multiSplit (x:xs) l = left : multiSplit (fmap (subtract x) xs) right where (left, right) = R.splitAt x l onRectangle :: (Int -> Int -> R.YiString -> R.YiString) -> BufferM () onRectangle f = do (reg, l, r) <- getRectangle modifyRegionB (mapLines (f l r)) reg openRectangle :: BufferM () openRectangle = onRectangle openLine where openLine l r line = left <> R.replicateChar (r - l) ' ' <> right where (left, right) = R.splitAt l line stringRectangle :: R.YiString -> BufferM () stringRectangle inserted = onRectangle stringLine where stringLine l r line = left <> inserted <> right where [left,_,right] = multiSplit [l,r] line killRectangle :: EditorM () killRectangle = do cutted <- withCurrentBuffer $ do (reg, l, r) <- getRectangle text <- readRegionB reg let (cutted, rest) = unzip $ fmap cut $ R.lines' text cut :: R.YiString -> (R.YiString, R.YiString) cut line = let [left,mid,right] = multiSplit [l,r] line in (mid, left <> right) replaceRegionB reg (R.unlines rest) return cutted setRegE (R.unlines cutted) yankRectangle :: EditorM () yankRectangle = do text <- R.lines' <$> getRegE withCurrentBuffer $ forM_ text $ \t -> do savingPointB $ insertN t lineDown yi-core-0.19.4/src/Yi/Search.hs0000644000000000000000000003750407346545000014267 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Search -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Search/Replace functions module Yi.Search ( setRegexE, -- :: SearchExp -> EditorM () resetRegexE, -- :: EditorM () getRegexE, -- :: EditorM (Maybe SearchExp) SearchMatch, SearchResult(..), SearchOption(..), doSearch, -- :: (Maybe String) -> [SearchOption] -- -> Direction -> YiM () searchInit, -- :: String -- -> [SearchOption] -- -> IO SearchExp continueSearch, -- :: SearchExp -- -> IO SearchResult makeSimpleSearch, -- * Batch search-replace searchReplaceRegionB, searchReplaceSelectionB, replaceString, searchAndRepRegion, searchAndRepRegion0, searchAndRepUnit, -- :: String -> String -> Bool -> TextUnit -> EditorM Bool -- * Incremental Search isearchInitE, isearchIsEmpty, isearchAddE, isearchPrevE, isearchNextE, isearchWordE, isearchHistory, isearchDelE, isearchCancelE, isearchFinishE, isearchCancelWithE, isearchFinishWithE, -- * Replace qrNext, qrReplaceAll, qrReplaceOne, qrFinish ) where import Lens.Micro.Platform ((.=)) import Control.Monad (void, when) import Data.Binary (Binary, get, put) import Data.Char (isAlpha, isUpper) import Data.Default (Default, def) import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, any, break, empty, length, null, takeWhile, unpack) import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8) import Data.Typeable (Typeable) import Yi.Buffer import Yi.Editor import Yi.History (historyFinishGen, historyMoveGen, historyStartGen) import Yi.Regex (SearchOption(..), makeSearchOptsM, emptyRegex, SearchExp(..)) import qualified Yi.Rope as R (YiString, null, toString, toText) import Yi.Search.Internal (getRegexE, resetRegexE, setRegexE) import Yi.String (showT) import Yi.Types (YiVariable) import Yi.Utils (fst3) import Yi.Window (Window) -- --------------------------------------------------------------------- -- -- | Global searching. Search for regex and move point to that position. -- @Nothing@ means reuse the last regular expression. @Just s@ means use -- @s@ as the new regular expression. Direction of search can be -- specified as either @Backward@ or @Forward@ (forwards in the buffer). -- Arguments to modify the compiled regular expression can be supplied -- as well. -- type SearchMatch = Region data SearchResult = PatternFound | PatternNotFound | SearchWrapped deriving Eq doSearch :: Maybe String -- ^ @Nothing@ means used previous -- pattern, if any. Complain otherwise. -- Use getRegexE to check for previous patterns -> [SearchOption] -- ^ Flags to modify the compiled regex -> Direction -- ^ @Backward@ or @Forward@ -> EditorM SearchResult doSearch (Just re) fs d = searchInit re d fs >>= withCurrentBuffer . continueSearch doSearch Nothing _ d = do mre <- getRegexE case mre of Nothing -> fail "No previous search pattern" -- NB Just r -> withCurrentBuffer (continueSearch (r,d)) -- | Set up a search. searchInit :: String -> Direction -> [SearchOption] -> EditorM (SearchExp, Direction) searchInit re d fs = do let Right c_re = makeSearchOptsM fs re setRegexE c_re searchDirectionA .= d return (c_re,d) -- | Do a search, placing cursor at first char of pattern, if found. -- Keymaps may implement their own regex language. How do we provide for this? -- Also, what's happening with ^ not matching sol? continueSearch :: (SearchExp, Direction) -> BufferM SearchResult continueSearch (c_re, dir) = do mp <- savingPointB $ do moveB Character dir -- start immed. after cursor rs <- regexB dir c_re moveB Document (reverseDir dir) -- wrap around ls <- regexB dir c_re return $ listToMaybe $ fmap Right rs ++ fmap Left ls maybe (return ()) (moveTo . regionStart . either id id) mp return $ f mp where f (Just (Right _)) = PatternFound f (Just (Left _)) = SearchWrapped f Nothing = PatternNotFound ------------------------------------------------------------------------ -- Batch search and replace -- -- | Search and Replace all within the current region. -- Note the region is the final argument since we might perform -- the same search and replace over multiple regions however we are -- unlikely to perform several search and replaces over the same region -- since the first such may change the bounds of the region. searchReplaceRegionB :: R.YiString -- ^ The string to search for -> R.YiString -- ^ The string to replace it with -> Region -- ^ The region to perform this over -> BufferM Int searchReplaceRegionB from to = searchAndRepRegion0 (makeSimpleSearch from) to True -- | Peform a search and replace on the selection searchReplaceSelectionB :: R.YiString -- ^ text to search for -> R.YiString -- ^ text to replace it with -> BufferM Int searchReplaceSelectionB from to = getSelectRegionB >>= searchReplaceRegionB from to -- | Replace a string by another everywhere in the document replaceString :: R.YiString -> R.YiString -> BufferM Int replaceString a b = regionOfB Document >>= searchReplaceRegionB a b ------------------------------------------------------------------------ -- | Search and replace in the given region. -- -- If the input boolean is True, then the replace is done globally, -- otherwise only the first match is replaced. Returns the number of -- replacements done. searchAndRepRegion0 :: SearchExp -> R.YiString -> Bool -> Region -> BufferM Int searchAndRepRegion0 c_re str globally region = do mp <- (if globally then id else take 1) <$> regexRegionB c_re region -- find the regex -- mp' is a maybe not reversed version of mp, the goal -- is to avoid replaceRegionB to mess up the next regions. -- So we start from the end. let mp' = mayReverse (reverseDir $ regionDirection region) mp mapM_ (`replaceRegionB` str) mp' return (length mp) searchAndRepRegion :: R.YiString -> R.YiString -> Bool -> Region -> EditorM Bool searchAndRepRegion s str globally region = case R.null s of False -> return False True -> do let c_re = makeSimpleSearch s setRegexE c_re -- store away for later use searchDirectionA .= Forward withCurrentBuffer $ (/= 0) <$> searchAndRepRegion0 c_re str globally region ------------------------------------------------------------------------ -- | Search and replace in the region defined by the given unit. -- The rest is as in 'searchAndRepRegion'. searchAndRepUnit :: R.YiString -> R.YiString -> Bool -> TextUnit -> EditorM Bool searchAndRepUnit re str g unit = withCurrentBuffer (regionOfB unit) >>= searchAndRepRegion re str g -------------------------- -- Incremental search newtype Isearch = Isearch [(T.Text, Region, Direction)] deriving (Typeable, Show) instance Binary Isearch where put (Isearch ts) = put (map3 E.encodeUtf8 ts) get = Isearch . map3 E.decodeUtf8 <$> get map3 :: (a -> d) -> [(a, b, c)] -> [(d, b, c)] map3 _ [] = [] map3 f ((a, b, c):xs) = (f a, b, c) : map3 f xs -- This contains: (string currently searched, position where we -- searched it, direction, overlay for highlighting searched text) -- Note that this info cannot be embedded in the Keymap state: the state -- modification can depend on the state of the editor. instance Default Isearch where def = Isearch [] instance YiVariable Isearch isearchInitE :: Direction -> EditorM () isearchInitE dir = do historyStartGen iSearch p <- withCurrentBuffer pointB putEditorDyn (Isearch [(T.empty ,mkRegion p p, dir)]) printMsg "I-search: " isearchIsEmpty :: EditorM Bool isearchIsEmpty = do Isearch s <- getEditorDyn return . not . T.null . fst3 $ head s isearchAddE :: T.Text -> EditorM () isearchAddE inc = isearchFunE (<> inc) -- | Create a SearchExp that matches exactly its argument makeSimpleSearch :: R.YiString -> SearchExp makeSimpleSearch s = se where Right se = makeSearchOptsM [QuoteRegex] (R.toString s) makeISearch :: T.Text -> SearchExp makeISearch s = case makeSearchOptsM opts (T.unpack s) of Left _ -> SearchExp (T.unpack s) emptyRegex emptyRegex [] Right search -> search where opts = QuoteRegex : if T.any isUpper s then [] else [IgnoreCase] isearchFunE :: (T.Text -> T.Text) -> EditorM () isearchFunE fun = do Isearch s <- getEditorDyn case s of [_] -> resetRegexE _ -> return () let (previous,p0,direction) = head s current = fun previous srch = makeISearch current printMsg $ "I-search: " <> current setRegexE srch prevPoint <- withCurrentBuffer pointB matches <- withCurrentBuffer $ do moveTo $ regionStart p0 when (direction == Backward) $ moveN $ T.length current regexB direction srch let onSuccess p = do withCurrentBuffer $ moveTo (regionEnd p) putEditorDyn $ Isearch ((current, p, direction) : s) case matches of (p:_) -> onSuccess p [] -> do matchesAfterWrap <- withCurrentBuffer $ do case direction of Forward -> moveTo 0 Backward -> do bufferLength <- sizeB moveTo bufferLength regexB direction srch case matchesAfterWrap of (p:_) -> onSuccess p [] -> do withCurrentBuffer $ moveTo prevPoint -- go back to where we were putEditorDyn $ Isearch ((current, p0, direction) : s) printMsg $ "Failing I-search: " <> current isearchDelE :: EditorM () isearchDelE = do Isearch s <- getEditorDyn case s of (_:(text,p,dir):rest) -> do withCurrentBuffer $ moveTo $ regionEnd p putEditorDyn $ Isearch ((text,p,dir):rest) setRegexE $ makeISearch text printMsg $ "I-search: " <> text _ -> return () -- if the searched string is empty, don't try to remove chars from it. isearchHistory :: Int -> EditorM () isearchHistory delta = do Isearch ((current,_p0,_dir):_) <- getEditorDyn h <- historyMoveGen iSearch delta (return current) isearchFunE (const h) isearchPrevE :: EditorM () isearchPrevE = isearchNext0 Backward isearchNextE :: EditorM () isearchNextE = isearchNext0 Forward isearchNext0 :: Direction -> EditorM () isearchNext0 newDir = do Isearch ((current,_p0,_dir):_rest) <- getEditorDyn if T.null current then isearchHistory 1 else isearchNext newDir isearchNext :: Direction -> EditorM () isearchNext direction = do Isearch ((current, p0, _dir) : rest) <- getEditorDyn withCurrentBuffer $ moveTo (regionStart p0 + startOfs) mp <- withCurrentBuffer $ regexB direction (makeISearch current) case mp of [] -> do endPoint <- withCurrentBuffer $ do moveTo (regionEnd p0) -- revert to offset we were before. sizeB printMsg "isearch: end of document reached" let wrappedOfs = case direction of Forward -> mkRegion 0 0 Backward -> mkRegion endPoint endPoint putEditorDyn $ Isearch ((current,wrappedOfs,direction):rest) -- prepare to wrap around. (p:_) -> do withCurrentBuffer $ moveTo (regionEnd p) printMsg $ "I-search: " <> current putEditorDyn $ Isearch ((current,p,direction):rest) where startOfs = case direction of Forward -> 1 Backward -> -1 isearchWordE :: EditorM () isearchWordE = do -- add maximum 32 chars at a time. text <- R.toText <$> withCurrentBuffer (pointB >>= nelemsB 32) let (prefix, rest) = T.break isAlpha text word = T.takeWhile isAlpha rest isearchAddE $ prefix <> word -- | Successfully finish a search. Also see 'isearchFinishWithE'. isearchFinishE :: EditorM () isearchFinishE = isearchEnd True -- | Cancel a search. Also see 'isearchCancelWithE'. isearchCancelE :: EditorM () isearchCancelE = isearchEnd False -- | Wrapper over 'isearchEndWith' that passes through the action and -- accepts the search as successful (i.e. when the user wants to stay -- at the result). isearchFinishWithE :: EditorM a -> EditorM () isearchFinishWithE act = isearchEndWith act True -- | Wrapper over 'isearchEndWith' that passes through the action and -- marks the search as unsuccessful (i.e. when the user wants to -- jump back to where the search started). isearchCancelWithE :: EditorM a -> EditorM () isearchCancelWithE act = isearchEndWith act False iSearch :: T.Text iSearch = "isearch" -- | Editor action describing how to end finish incremental search. -- The @act@ parameter allows us to specify an extra action to run -- before finishing up the search. For Vim, we don't want to do -- anything so we use 'isearchEnd' which just does nothing. For emacs, -- we want to cancel highlighting and stay where we are. isearchEndWith :: EditorM a -> Bool -> EditorM () isearchEndWith act accept = getEditorDyn >>= \case Isearch [] -> return () Isearch s@((lastSearched, _, dir):_) -> do let (_,p0,_) = last s historyFinishGen iSearch (return lastSearched) searchDirectionA .= dir if accept then do void act printMsg "Quit" else do resetRegexE withCurrentBuffer $ moveTo $ regionStart p0 -- | Specialised 'isearchEndWith' to do nothing as the action. isearchEnd :: Bool -> EditorM () isearchEnd = isearchEndWith (return ()) ----------------- -- Query-Replace -- | Find the next match and select it. -- Point is end, mark is beginning. qrNext :: Window -> BufferRef -> SearchExp -> EditorM () qrNext win b what = do mp <- withGivenBufferAndWindow win b $ regexB Forward what case mp of [] -> do printMsg "String to search not found" qrFinish (r:_) -> withGivenBufferAndWindow win b $ setSelectRegionB r -- | Replace all the remaining occurrences. qrReplaceAll :: Window -> BufferRef -> SearchExp -> R.YiString -> EditorM () qrReplaceAll win b what replacement = do n <- withGivenBufferAndWindow win b $ do exchangePointAndMarkB -- so we replace the current occurrence too searchAndRepRegion0 what replacement True =<< regionOfPartB Document Forward printMsg $ "Replaced " <> showT n <> " occurrences" qrFinish -- | Exit from query/replace. qrFinish :: EditorM () qrFinish = do currentRegexA .= Nothing closeBufferAndWindowE -- the minibuffer. -- | We replace the currently selected match and then move to the next -- match. qrReplaceOne :: Window -> BufferRef -> SearchExp -> R.YiString -> EditorM () qrReplaceOne win b reg replacement = do qrReplaceCurrent win b replacement qrNext win b reg -- | This may actually be a bit more general it replaces the current -- selection with the given replacement string in the given window and -- buffer. qrReplaceCurrent :: Window -> BufferRef -> R.YiString -> EditorM () qrReplaceCurrent win b replacement = withGivenBufferAndWindow win b $ flip replaceRegionB replacement =<< getRawestSelectRegionB yi-core-0.19.4/src/Yi/Search/0000755000000000000000000000000007346545000013722 5ustar0000000000000000yi-core-0.19.4/src/Yi/Search/Internal.hs0000644000000000000000000000201107346545000016024 0ustar0000000000000000{-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Search.Internal -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Internal use for Yi.Search. module Yi.Search.Internal where import Lens.Micro.Platform ((.=), use) import Yi.Editor (EditorM, currentRegexA) import Yi.Regex (SearchExp) -- --------------------------------------------------------------------- -- Searching and substitutions with regular expressions -- -- The most recent regex is held by the editor. You can get at it with -- getRegeE. This is useful to determine if there was a previous -- pattern. -- -- | Put regex into regex 'register' setRegexE :: SearchExp -> EditorM () setRegexE re = currentRegexA .= (Just re) -- | Clear the regex 'register' resetRegexE :: EditorM () resetRegexE = currentRegexA .= Nothing -- | Return contents of regex register getRegexE :: EditorM (Maybe SearchExp) getRegexE = use currentRegexA yi-core-0.19.4/src/Yi/String.hs0000644000000000000000000001164207346545000014323 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.String -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- String manipulation utilities module Yi.String (isBlank, chomp, capitalize, capitalizeFirst, dropSpace, fillText, onLines, mapLines, lines', unlines', padLeft, padRight, commonTPrefix, commonTPrefix', listify, showT, overInit, overTail ) where import Data.Char (isAlphaNum, isSpace, toLower, toUpper) import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T (Text, break, commonPrefixes, empty, intercalate, pack, splitAt, splitOn, toUpper) import qualified Yi.Rope as R (YiString, all, cons, head, init, intercalate, last, length, lines', snoc, tail, unwords, withText, words) -- | Helper that shows then packs the 'Text', for all those cases -- where we use 'show'. showT :: Show a => a -> T.Text showT = T.pack . show -- | This is kind of like the default Show instance for lists except -- over 'T.Text'. It does not leave the elements in extra quotes and -- should not be attempted to be 'show'n and 'read' back. listify :: [R.YiString] -> R.YiString listify t = '[' `R.cons` R.intercalate ", " t `R.snoc` ']' -- | Works by resupplying the found prefix back into the list, -- eventually either finding the prefix or not matching. commonTPrefix :: [T.Text] -> Maybe T.Text commonTPrefix (x:y:xs) = case T.commonPrefixes x y of Nothing -> Nothing Just (p, _, _) -> commonTPrefix (p : xs) commonTPrefix [x] = Just x commonTPrefix _ = Nothing -- | Like 'commonTPrefix' but returns empty text on failure. commonTPrefix' :: [T.Text] -> T.Text commonTPrefix' = fromMaybe T.empty . commonTPrefix capitalize :: String -> String capitalize [] = [] capitalize (c:cs) = toUpper c : map toLower cs capitalizeFirst :: R.YiString -> R.YiString capitalizeFirst = R.withText go where go x = case T.break isAlphaNum x of (f, b) -> f <> case T.splitAt 1 b of (h, hs) -> T.toUpper h <> hs -- | Remove any trailing strings matching /irs/ (input record separator) -- from input string. Like Perl's chomp(1). chomp :: String -> String -> String chomp irs st | irs `isSuffixOf` st = let st' = reverse $ drop (length irs) (reverse st) in chomp irs st' | otherwise = st {-# INLINE chomp #-} -- | Trim spaces at beginning /and/ end dropSpace :: String -> String dropSpace = let f = reverse . dropWhile isSpace in f . f isBlank :: R.YiString -> Bool isBlank = R.all isSpace -- | Fills lines up to the given length, splitting the text up if -- necessary. fillText :: Int -> R.YiString -> [R.YiString] fillText margin = map (R.unwords . reverse) . fill 0 [] . R.words where fill _ acc [] = [acc] fill n acc (w:ws) | n + R.length w >= margin = acc : fill (R.length w) [w] ws | otherwise = fill (n + 1 + R.length w) (w:acc) ws -- | @overInit f@ runs f over the 'R.init' of the input if possible, -- preserving the 'R.last' element as-is. If given a string with -- length ≤ 1, it effectively does nothing. -- -- Also see 'overTail'. overInit :: (R.YiString -> R.YiString) -> R.YiString -> R.YiString overInit f t = case (R.init t, R.last t) of (Just xs, Just x) -> f xs `R.snoc` x _ -> t -- | @overInit f@ runs f over the 'R.tail' of the input if possible, -- preserving the 'R.head' element as-is. If given a string with -- length ≤ 1, it effectively does nothing. -- -- Also see 'overInit'. overTail :: (R.YiString -> R.YiString) -> R.YiString -> R.YiString overTail f t = case (R.head t, R.tail t) of (Just x, Just xs) -> x `R.cons` f xs _ -> t -- | Inverse of 'lines''. In contrast to 'Prelude.unlines', this does -- not add an empty line at the end. unlines' :: [T.Text] -> T.Text unlines' = T.intercalate "\n" -- | Split a Text in lines. Unlike 'Prelude.lines', this does not -- remove any empty line at the end. lines' :: T.Text -> [T.Text] lines' = T.splitOn "\n" -- | A helper function for creating functions suitable for -- 'modifySelectionB' and 'modifyRegionB'. -- To be used when the desired function should map across -- the lines of a region. mapLines :: (R.YiString -> R.YiString) -> R.YiString -> R.YiString mapLines f = onLines $ fmap f onLines :: ([R.YiString] -> [R.YiString]) -> R.YiString -> R.YiString onLines f = mconcat . f . R.lines' padLeft, padRight :: Int -> String -> String padLeft n [] = replicate n ' ' padLeft n (x:xs) = x : padLeft (n-1) xs padRight n = reverse . padLeft n . reverse yi-core-0.19.4/src/Yi/Syntax/0000755000000000000000000000000007346545000014003 5ustar0000000000000000yi-core-0.19.4/src/Yi/Syntax/Driver.hs0000644000000000000000000000552007346545000015574 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | This module defines implementations of syntax-awareness drivers. module Yi.Syntax.Driver where import Data.Map (Map) import qualified Data.Map as M (Map, assocs, empty, findWithDefault, fromList) import Yi.Buffer.Basic (WindowRef) import Yi.Lexer.Alex (Tok) import Yi.Syntax hiding (Cache) import Yi.Syntax.Tree (IsTree, fromNodeToFinal) type Path = [Int] data Cache state tree tt = Cache { path :: M.Map WindowRef Path, cachedStates :: [state], root :: tree (Tok tt), focused :: !(M.Map WindowRef (tree (Tok tt))) } mkHighlighter :: forall state tree tt. (IsTree tree, Show state) => (Scanner Point Char -> Scanner state (tree (Tok tt))) -> Highlighter (Cache state tree tt) (tree (Tok tt)) mkHighlighter scanner = Yi.Syntax.SynHL { hlStartState = Cache M.empty [] emptyResult M.empty , hlRun = updateCache , hlGetTree = \(Cache _ _ _ focused) w -> M.findWithDefault emptyResult w focused , hlFocus = focus } where startState :: state startState = scanInit (scanner emptyFileScan) emptyResult = scanEmpty (scanner emptyFileScan) updateCache :: Scanner Point Char -> Point -> Cache state tree tt -> Cache state tree tt updateCache newFileScan dirtyOffset (Cache path cachedStates oldResult _) = Cache path newCachedStates newResult M.empty where newScan = scanner newFileScan reused :: [state] reused = takeWhile ((< dirtyOffset) . scanLooked (scanner newFileScan)) cachedStates resumeState :: state resumeState = if null reused then startState else last reused newCachedStates = reused ++ fmap fst recomputed recomputed = scanRun newScan resumeState newResult :: tree (Tok tt) newResult = if null recomputed then oldResult else snd $ head recomputed focus r (Cache path states root _focused) = Cache path' states root focused where (path', focused) = unzipFM $ zipWithFM (\newpath oldpath -> fromNodeToFinal newpath (oldpath,root)) [] r path unzipFM :: Ord k => [(k,(u,v))] -> (Map k u, Map k v) unzipFM l = (M.fromList mu, M.fromList mv) where (mu, mv) = unzip [((k,u),(k,v)) | (k,(u,v)) <- l] zipWithFM :: Ord k => (u -> v -> w) -> v -> Map k u -> Map k v -> [(k,w)] zipWithFM f v0 mu mv = [ (k,f u (M.findWithDefault v0 k mv) ) | (k,u) <- M.assocs mu] yi-core-0.19.4/src/Yi/Syntax/Layout.hs0000644000000000000000000001471107346545000015620 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} -- Note: If the first line of the file has wrong indentation, some of the -- code might be left outside of the blocks module Yi.Syntax.Layout (layoutHandler, State) where import Data.List (find) import Data.Maybe (isJust) import Yi.Lexer.Alex (AlexState (..), Posn (Posn), Tok (Tok, tokPosn, tokT), startPosn) import Yi.Syntax (Scanner (..)) data BlockOpen t = Indent Int -- block opened because of indentation; parameter is the column of it. | Paren t -- block opened because of parentheses deriving Show isParen :: BlockOpen t -> Bool isParen (Paren _) = True isParen _ = False data IState t = IState [BlockOpen t] -- current block nesting Bool -- should we open a compound now ? Int -- last line number deriving Show type State t lexState = (IState t, AlexState lexState) -- | Transform a scanner into a scanner that also adds opening, -- closing and "next" tokens to indicate layout. -- @isSpecial@ predicate indicates a token that starts a compound, -- like "where", "do", ... -- @isIgnore@ predicate indicates a token that is to be ignored for -- layout. (eg. pre-processor directive...) -- @parens@ is a list of couple of matching parenthesis-like tokens -- "()[]{}...". layoutHandler :: forall t lexState. (Show t, Eq t) => (t -> Bool) -> [(t,t)] -> (Tok t -> Bool) -> (t,t,t) -> (Tok t -> Bool) -> Scanner (AlexState lexState) (Tok t) -> Scanner (State t lexState) (Tok t) layoutHandler isSpecial parens isIgnored (openT, closeT, nextT) isGroupOpen lexSource = Scanner { scanLooked = scanLooked lexSource . snd, scanEmpty = error "layoutHandler: scanEmpty", scanInit = (IState [] True (-1), scanInit lexSource), scanRun = \st -> let result = parse (fst st) (scanRun lexSource (snd st)) in --trace ("toks = " ++ show (fmap snd result)) $ result } where dummyAlexState = AlexState { stLexer = error "dummyAlexState: should not be reused for restart!", lookedOffset = maxBound, -- setting this to maxBound ensures nobody ever uses it. stPosn = startPosn } deepestIndent [] = -1 deepestIndent (Indent i:_) = i deepestIndent (_:levs) = deepestIndent levs deepestParen _ [] = False deepestParen p (Paren t:levs) = p == t || deepestParen p levs deepestParen p (_:levs) = deepestParen p levs findParen f t = find ((== t) . f) parens parse :: IState t -> [(AlexState lexState, Tok t)] -> [(State t lexState, Tok t)] parse iSt@(IState levels doOpen lastLine) toks@((aSt, tok@Tok {tokPosn = Posn _nextOfs line col}) : tokss) -- ignore this token | isIgnored tok = (st, tok) : parse (IState levels doOpen line) tokss -- start a compound if the rest of the line is empty then skip to it! | doOpen = if isGroupOpen tok -- check so that the do is not followed by a { then parse (IState levels False lastLine) toks else (st', tt openT) : parse (IState (Indent col : levels) False line) toks -- if it's a block opening, we ignore the layout, and just let the "normal" rule -- handle the creation of another level. -- close, or prepare to close, a paren block | Just (openTok,_) <- findParen snd $ tokT tok, deepestParen openTok levels = case levels of Indent _:levs -> (st',tt closeT) : parse (IState levs False lastLine) toks -- close an indent level inside the paren block Paren openTok' :levs | openTok == openTok' -> (st', tok) : parse (IState levs False line) tokss | otherwise -> parse (IState levs False line) toks -- close one level of nesting. [] -> error $ "Parse: " ++ show iSt -- pop an indent block | col < deepestIndent levels = let (_lev:levs) = dropWhile isParen levels in (st', tt closeT) : parse (IState levs doOpen lastLine) toks -- drop all paren levels inside the indent -- next item | line > lastLine && col == deepestIndent levels = (st', tt nextT) : parse (IState (dropWhile isParen levels) doOpen line) toks -- drop all paren levels inside the indent -- open a paren block | isJust $ findParen fst $ tokT tok = (st', tok) : parse (IState (Paren (tokT tok):levels) (isSpecial (tokT tok)) line) tokss -- important note: the the token can be both special and an opening. This is the case of the -- haskell 'let' (which is closed by 'in'). In that case the inner block is that of the indentation. -- prepare to open a compound | isSpecial (tokT tok) = (st', tok) : parse (IState levels True line) tokss | otherwise = (st', tok) : parse (IState levels doOpen line) tokss where st = (iSt, aSt) st' = (iSt, aSt {lookedOffset = max peeked (lookedOffset aSt)}) tt t = Tok t 0 (tokPosn tok) peeked = case tokss of [] -> maxBound (AlexState {lookedOffset = p},_):_ -> p -- This function checked the position and kind of the -- next token. We peeked further, and so must -- update the lookedOffset accordingly. -- finish by closing all the indent states. parse iSt@(IState (Indent _:levs) doOpen posn) [] = ((iSt,dummyAlexState), Tok closeT 0 maxPosn) : parse (IState levs doOpen posn) [] parse (IState (Paren _:levs) doOpen posn) [] = parse (IState levs doOpen posn) [] parse (IState [] _ _) [] = [] maxPosn :: Posn maxPosn = Posn (-1) (-1) 0 -- HACK! here we have collusion between using (-1) here and the parsing of -- OnlineTrees, which relies on the position of the last token to stop -- the parsing. yi-core-0.19.4/src/Yi/Syntax/OnlineTree.hs0000644000000000000000000000250307346545000016403 0ustar0000000000000000{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- uniplate patterns {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Syntax.OnlineTree -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Module defining the 'Tree' used as part of many 'Mode's. module Yi.Syntax.OnlineTree (Tree(..), manyToks, tokAtOrBefore) where import Yi.IncrementalParse (P, Parser (Look), symbol) import Yi.Lexer.Alex (Tok) import Yi.Syntax.Tree (IsTree (emptyNode, uniplate), tokAtOrBefore) data Tree a = Bin (Tree a) (Tree a) | Leaf a | Tip deriving (Show, Functor, Foldable, Traversable) instance IsTree Tree where emptyNode = Tip uniplate (Bin l r) = ([l,r],\[l',r'] -> Bin l' r') uniplate t = ([],const t) manyToks :: P (Tok t) (Tree (Tok t)) manyToks = manyToks' 1 manyToks' :: Int -> P a (Tree a) manyToks' n = Look (pure Tip) (\_ -> Bin <$> subTree n <*> manyToks' (n * 2)) subTree :: Int -> P a (Tree a) subTree n = Look (pure Tip) . const $ case n of 0 -> pure Tip 1 -> Leaf <$> symbol (const True) _ -> let m = n `div` 2 in Bin <$> subTree m <*> subTree m yi-core-0.19.4/src/Yi/Syntax/Tree.hs0000644000000000000000000002753507346545000015252 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- the CPP seems to confuse GHC; we have uniplate patterns {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-incomplete-patterns #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Syntax.Tree -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- Generic syntax tree handling functions module Yi.Syntax.Tree (IsTree(..), toksAfter, allToks, tokAtOrBefore, toksInRegion, sepBy, sepBy1, getLastOffset, getFirstOffset, getFirstElement, getLastElement, getLastPath, getAllSubTrees, tokenBasedAnnots, tokenBasedStrokes, subtreeRegion, fromLeafToLeafAfter, fromNodeToFinal) where -- Some of this might be replaced by a generic package -- such as multirec, uniplace, emgm, ... import Prelude hiding (concatMap, error) import Control.Applicative (Alternative ((<|>), many)) import Control.Arrow (first) import Data.Foldable (concatMap, toList) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE (reverse, toList, (<|)) import Data.Maybe (catMaybes, listToMaybe) import Data.Monoid (First (First, getFirst), Last (Last, getLast), (<>)) import Yi.Buffer.Basic (Point) import Yi.Debug (error, trace) import Yi.Lexer.Alex (posnLine, posnOfs, Tok (tokPosn), tokBegin, tokEnd) import Yi.Region (Region (regionEnd, regionStart), mkRegion) import Yi.String (showT) -- Fundamental types type Path = [Int] type Node t = (Path, t) class Foldable tree => IsTree tree where -- | Direct subtrees of a tree subtrees :: tree t -> [tree t] subtrees = fst . uniplate uniplate :: tree t -> ([tree t], [tree t] -> tree t) emptyNode :: tree t toksAfter :: Foldable t1 => t -> t1 a -> [a] toksAfter _begin = allToks allToks :: Foldable t => t a -> [a] allToks = toList tokAtOrBefore :: Foldable t => Point -> t (Tok t1) -> Maybe (Tok t1) tokAtOrBefore p res = listToMaybe $ reverse $ toksInRegion (mkRegion 0 (p+1)) res toksInRegion :: Foldable t1 => Region -> t1 (Tok t) -> [Tok t] toksInRegion reg = takeWhile (\t -> tokBegin t <= regionEnd reg) . dropWhile (\t -> tokEnd t < regionStart reg) . toksAfter (regionStart reg) tokenBasedAnnots :: (Foldable t1) => (a1 -> Maybe a) -> t1 a1 -> t -> [a] tokenBasedAnnots tta t begin = catMaybes (tta <$> toksAfter begin t) tokenBasedStrokes :: (Foldable t3) => (a -> b) -> t3 a -> t -> t2 -> t1 -> [b] tokenBasedStrokes tts t _point begin _end = tts <$> toksAfter begin t -- | Prune the nodes before the given point. -- The path is used to know which nodes we can force or not. pruneNodesBefore :: IsTree tree => Point -> Path -> tree (Tok a) -> tree (Tok a) pruneNodesBefore _ [] t = t pruneNodesBefore p (x:xs) t = rebuild $ left' <> (pruneNodesBefore p xs c : rs) where (children,rebuild) = uniplate t (left,c:rs) = splitAt x children left' = fmap replaceEmpty left replaceEmpty s = if getLastOffset s < p then emptyNode else s -- | Given an approximate path to a leaf at the end of the region, -- return: (path to leaf at the end of the region,path from focused -- node to the leaf, small node encompassing the region) fromNodeToFinal :: IsTree tree => Region -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromNodeToFinal r (xs,root) = trace ("r = " <> showT r) $ trace ("focused ~ " <> showT (subtreeRegion focused) ) $ trace ("pathFromFocusedToLeaf = " <> showT focusedToLeaf) $ trace ("pruned ~ " <> showT (subtreeRegion focused)) (xs', pruned) where n@(xs',_) = fromLeafToLeafAfter (regionEnd r) (xs,root) (_,(focusedToLeaf,focused)) = fromLeafAfterToFinal p0 n p0 = regionStart r pruned = pruneNodesBefore p0 focusedToLeaf focused -- | Return the first element that matches the predicate, or the last -- of the list if none matches. firstThat :: (a -> Bool) -> NonEmpty a -> a firstThat _ (x :| []) = x firstThat p (x :| [y]) = if p x then x else y firstThat p (x :| y : xs) = if p x then x else firstThat p (y :| xs) -- | Return the element before first element that violates the -- predicate, or the first of the list if that one violates the -- predicate. lastThat :: (a -> Bool) -> NonEmpty a -> a lastThat p (x :| xs) = if p x then work x xs else x where work x0 [] = x0 work x0 (y:ys) = if p y then work y ys else x0 -- | Given a path to a node, return a path+node which node that -- encompasses the given node + a point before it. fromLeafAfterToFinal :: IsTree tree => Point -> Node (tree (Tok a)) -> (Path, Node (tree (Tok a))) fromLeafAfterToFinal p n = -- trace ("reg = " <> showT (fmap (subtreeRegion . snd) nsPth)) $ firstThat (\(_,(_,s)) -> getFirstOffset s <= p) ns where ns = NE.reverse (nodesOnPath n) -- | Search the tree in pre-order starting at a given node, until -- finding a leaf which is at or after the given point. An effort is -- also made to return a leaf as close as possible to @p@. -- -- TODO: rename to fromLeafToLeafAt fromLeafToLeafAfter :: IsTree tree => Point -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromLeafToLeafAfter p (xs, root) = trace "fromLeafToLeafAfter:" $ trace ("xs = " <> showT xs) $ trace ("xsValid = " <> showT xsValid) $ trace ("p = " <> showT p) $ trace ("leafBeforeP = " <> showT leafBeforeP) $ trace ("leaf ~ " <> showT (subtreeRegion leaf)) $ trace ("xs' = " <> showT xs') result where xs' = case candidateLeaves of [] -> [] c:cs -> fst $ firstOrLastThat (\(_,s) -> getFirstOffset s >= p) (c :| cs) candidateLeaves = allLeavesRelative relChild n (firstOrLastThat,relChild) = if leafBeforeP then (firstThat,afterChild) else (lastThat,beforeChild) (xsValid,leaf) = wkDown (xs,root) leafBeforeP = getFirstOffset leaf <= p n = (xsValid,root) result = (xs',root) allLeavesRelative :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Node (tree a) -> [Node (tree a)] allLeavesRelative select = filter (not . nullSubtree . snd) . allLeavesRelative' select . NE.toList . NE.reverse . nodesAndChildIndex -- we remove empty subtrees because their region is [0,0]. -- | Takes a list of (node, index of already inspected child), and -- return all leaves in this node after the said child). allLeavesRelative' :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> [(Node (tree a), Int)] -> [Node (tree a)] allLeavesRelative' select l = [(xs <> xs', t') | ((xs,t),c) <- l , (xs',t') <- allLeavesRelativeChild select c t] -- | Given a root, return all the nodes encountered along it, their -- paths, and the index of the child which comes next. nodesAndChildIndex :: IsTree tree => Node (tree a) -> NonEmpty (Node (tree a), Int) nodesAndChildIndex ([],t) = return (([],t),negate 1) nodesAndChildIndex (x:xs, t) = case index x (subtrees t) of Just c' -> (([],t), x) NE.<| fmap (first $ first (x:)) (nodesAndChildIndex (xs,c')) Nothing -> return (([],t),negate 1) nodesOnPath :: IsTree tree => Node (tree a) -> NonEmpty (Path, Node (tree a)) nodesOnPath ([],t) = return ([],([],t)) nodesOnPath (x:xs,t) = ([],(x:xs,t)) NE.<| case index x (subtrees t) of Nothing -> error "nodesOnPath: non-existent path" Just c -> fmap (first (x:)) (nodesOnPath (xs,c)) beforeChild :: Int -> [a] -> [a] beforeChild (-1) = reverse -- (-1) indicates that all children should be taken. beforeChild c = reverse . take (c-1) afterChild :: Int -> [a] -> [a] afterChild c = drop (c+1) -- | Return all leaves after or before child depending on the relation -- which is given. allLeavesRelativeChild :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] allLeavesRelativeChild select c t | null ts = return ([], t) | otherwise = [(x:xs,t') | (x,ct) <- select c (zip [0..] ts), (xs, t') <- allLeavesIn select ct] where ts = subtrees t -- | Return all leaves (with paths) inside a given root. allLeavesIn :: (IsTree tree) => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> tree a -> [Node (tree a)] allLeavesIn select = allLeavesRelativeChild select (-1) -- | Return all subtrees in a tree; each element of the return list -- contains paths to nodes. (Root is at the start of each path) getAllPaths :: IsTree tree => tree t -> [[tree t]] getAllPaths t = fmap (<>[t]) ([] : concatMap getAllPaths (subtrees t)) goDown :: IsTree tree => Int -> tree t -> Maybe (tree t) goDown i = index i . subtrees index :: Int -> [a] -> Maybe a index _ [] = Nothing index 0 (h:_) = Just h index n (_:t) = index (n-1) t walkDown :: IsTree tree => Node (tree t) -> Maybe (tree t) walkDown ([],t) = return t walkDown (x:xs,t) = goDown x t >>= curry walkDown xs wkDown :: IsTree tree => Node (tree a) -> Node (tree a) wkDown ([],t) = ([],t) wkDown (x:xs,t) = case goDown x t of Nothing -> ([],t) Just t' -> first (x:) $ wkDown (xs,t') -- | Search the given list, and return the last tree before the given -- point; with path to the root. (Root is at the start of the path) getLastPath :: IsTree tree => [tree (Tok t)] -> Point -> Maybe [tree (Tok t)] getLastPath roots offset = case takeWhile ((< offset) . posnOfs . snd) allSubPathPosn of [] -> Nothing xs -> Just $ fst $ last xs where allSubPathPosn = [ (p,posn) | root <- roots , p@(t':_) <- getAllPaths root , Just tok <- [getFirstElement t'] , let posn = tokPosn tok ] -- | Return all subtrees in a tree, in preorder. getAllSubTrees :: IsTree tree => tree t -> [tree t] getAllSubTrees t = t : concatMap getAllSubTrees (subtrees t) -- | Return the 1st token of a subtree. getFirstElement :: Foldable t => t a -> Maybe a getFirstElement tree = getFirst $ foldMap (First . Just) tree nullSubtree :: Foldable t => t a -> Bool nullSubtree = null . toList getFirstTok, getLastTok :: Foldable t => t a -> Maybe a getFirstTok = getFirstElement getLastTok = getLastElement -- | Return the last token of a subtree. getLastElement :: Foldable t => t a -> Maybe a getLastElement tree = getLast $ foldMap (Last . Just) tree getFirstOffset, getLastOffset :: Foldable t => t (Tok t1) -> Point getFirstOffset = maybe 0 tokBegin . getFirstTok getLastOffset = maybe 0 tokEnd . getLastTok subtreeRegion :: Foldable t => t (Tok t1) -> Region subtreeRegion t = mkRegion (getFirstOffset t) (getLastOffset t) -- | Given a tree, return (first offset, number of lines). getSubtreeSpan :: (Foldable tree) => tree (Tok t) -> (Point, Int) getSubtreeSpan tree = (posnOfs firstOff, lastLine - firstLine) where bounds@[firstOff, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree] [firstLine, lastLine] = fmap posnLine bounds assertJust (Just x) = x assertJust _ = error "assertJust: Just expected" ------------------------------------- -- Should be in Control.Applicative.? sepBy :: (Alternative f) => f a -> f v -> f [a] sepBy p s = sepBy1 p s <|> pure [] sepBy1 :: (Alternative f) => f a -> f v -> f [a] sepBy1 p s = (:) <$> p <*> many (s *> p) yi-core-0.19.4/src/Yi/Tab.hs0000644000000000000000000001007207346545000013557 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} module Yi.Tab ( Tab, TabRef, tabWindowsA, tabLayoutManagerA, tabDividerPositionA, tkey, tabMiniWindows, tabFocus, forceTab, mapWindows, tabLayout, tabFoldl, makeTab, makeTab1, ) where import Prelude hiding (foldl, foldr) import Lens.Micro.Platform (Lens', lens, over, (^.)) import qualified Data.Binary as Binary (Binary, get, put) import Data.Default (def) import Data.Foldable (foldl, foldr, toList) import qualified Data.List.PointedList as PL (PointedList, singleton, _focus) import Data.Typeable (Typeable) import Yi.Buffer.Basic (WindowRef) import Yi.Layout import Yi.Window (Window, isMini, wkey) type TabRef = Int -- | A tab, containing a collection of windows. data Tab = Tab { tkey :: !TabRef, -- ^ For UI sync; fixes #304 tabWindows :: !(PL.PointedList Window), -- ^ Visible windows tabLayout :: !(Layout WindowRef), -- ^ Current layout. Invariant: must be the layout generated by 'tabLayoutManager', up to changing the 'divPos's. tabLayoutManager :: !AnyLayoutManager -- ^ layout manager (for regenerating the layout when we add/remove windows) } deriving Typeable tabFocus :: Tab -> Window tabFocus = PL._focus . tabWindows -- | Returns a list of all mini windows associated with the given tab tabMiniWindows :: Tab -> [Window] tabMiniWindows = Prelude.filter isMini . toList . tabWindows -- | Accessor for the windows. If the windows (but not the focus) have changed when setting, then a relayout will be triggered to preserve the internal invariant. tabWindowsA :: Functor f => (PL.PointedList Window -> f (PL.PointedList Window)) -> Tab -> f Tab tabWindowsA f s = (`setter` s) <$> f (getter s) where setter ws t = relayoutIf (toList ws /= toList (tabWindows t)) (t { tabWindows = ws}) getter = tabWindows -- | Accessor for the layout manager. When setting, will trigger a relayout if the layout manager has changed. tabLayoutManagerA :: Functor f => (AnyLayoutManager -> f AnyLayoutManager) -> Tab -> f Tab tabLayoutManagerA f s = (`setter` s) <$> f (getter s) where setter lm t = relayoutIf (lm /= tabLayoutManager t) (t { tabLayoutManager = lm }) getter = tabLayoutManager -- | Gets / sets the position of the divider with the given reference. The caller must ensure that the DividerRef is valid, otherwise an error will (might!) occur. tabDividerPositionA :: DividerRef -> Lens' Tab DividerPosition tabDividerPositionA ref = lens tabLayout (\ t l -> t{tabLayout = l}) . dividerPositionA ref relayoutIf :: Bool -> Tab -> Tab relayoutIf False t = t relayoutIf True t = relayout t relayout :: Tab -> Tab relayout t = t { tabLayout = buildLayout (tabWindows t) (tabLayoutManager t) (tabLayout t) } instance Binary.Binary Tab where put (Tab tk ws _ _) = Binary.put tk >> Binary.put ws get = makeTab <$> Binary.get <*> Binary.get -- | Equality on tab identity (the 'tkey') instance Eq Tab where (==) t1 t2 = tkey t1 == tkey t2 instance Show Tab where show t = "Tab " ++ show (tkey t) -- | A specialised version of "fmap". mapWindows :: (Window -> Window) -> Tab -> Tab mapWindows f = over tabWindowsA (fmap f) -- | Forces all windows in the tab forceTab :: Tab -> Tab forceTab t = foldr seq t (t ^. tabWindowsA) -- | Folds over the windows in the tab tabFoldl :: (a -> Window -> a) -> a -> Tab -> a tabFoldl f z t = foldl f z (t ^. tabWindowsA) -- | Run the layout on the given tab, for the given aspect ratio buildLayout :: PL.PointedList Window -> AnyLayoutManager -> Layout WindowRef -> Layout WindowRef buildLayout ws m l = pureLayout m l . fmap wkey . Prelude.filter (not . isMini) . toList $ ws -- | Make a tab from multiple windows makeTab :: TabRef -> PL.PointedList Window -> Tab makeTab key ws = Tab key ws (buildLayout ws def def) def -- | Make a tab from one window makeTab1 :: TabRef -> Window -> Tab makeTab1 key win = makeTab key (PL.singleton win) yi-core-0.19.4/src/Yi/Tag.hs0000644000000000000000000001222107346545000013562 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Yi.Tag -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- A module for CTags integration. Note that this reads the ‘tags’ -- file produced by @hasktags@, not the ‘TAGS’ file which uses a -- different format (etags). module Yi.Tag ( lookupTag , importTagTable , hintTags , completeTag , Tag(..) , unTag' , TagTable(..) , getTags , setTags , resetTags , tagsFileList , readCTags ) where import GHC.Generics (Generic) import Lens.Micro.Platform (makeLenses) import Data.Binary (Binary) import qualified Data.ByteString as BS (readFile) import Data.Default (Default, def) import qualified Data.Foldable as F (concat) import Data.Map (Map, fromListWith, keys, lookup) import Data.Maybe (mapMaybe) import qualified Data.Text as T (Text, append, isPrefixOf, lines, unpack, words) import qualified Data.Text.Encoding as E (decodeUtf8) import qualified Data.Text.Read as R (decimal) import qualified Yi.CompletionTree as CT import System.FilePath (takeDirectory, takeFileName, ()) import System.FriendlyPath (expandTilda) import Yi.Config.Simple.Types (Field, customVariable) import Yi.Editor (EditorM, getEditorDyn, putEditorDyn) import Yi.Types (YiConfigVariable, YiVariable) newtype TagsFileList = TagsFileList { _unTagsFileList :: [FilePath] } instance Default TagsFileList where def = TagsFileList ["tags"] instance YiConfigVariable TagsFileList makeLenses ''TagsFileList tagsFileList :: Field [FilePath] tagsFileList = customVariable . unTagsFileList newtype Tags = Tags (Maybe TagTable) deriving (Binary) instance Default Tags where def = Tags Nothing instance YiVariable Tags newtype Tag = Tag { _unTag :: T.Text } deriving (Show, Eq, Ord, Binary) unTag' :: Tag -> T.Text unTag' = _unTag data TagTable = TagTable { tagFileName :: FilePath -- ^ local name of the tag file -- TODO: reload if this file is changed , tagBaseDir :: FilePath -- ^ path to the tag file directory -- tags are relative to this path , tagFileMap :: Map Tag [(FilePath, Int)] -- ^ map from tags to files , tagCompletionTree :: CT.CompletionTree T.Text -- ^ trie to speed up tag hinting } deriving (Generic) -- | Find the location of a tag using the tag table. -- Returns a full path and line number lookupTag :: Tag -> TagTable -> [(FilePath, Int)] lookupTag tag tagTable = do (file, line) <- F.concat . Data.Map.lookup tag $ tagFileMap tagTable return (tagBaseDir tagTable file, line) -- | Super simple parsing CTag format 1 parsing algorithm -- TODO: support search patterns in addition to lineno readCTags :: T.Text -> Map Tag [(FilePath, Int)] readCTags = fromListWith (++) . mapMaybe (parseTagLine . T.words) . T.lines where parseTagLine (tag:tagfile:lineno:_) = -- remove ctag control lines if "!_TAG_" `T.isPrefixOf` tag then Nothing else Just (Tag tag, [(T.unpack tagfile, getLineNumber lineno)]) where getLineNumber = (\(Right x) -> x) . fmap fst . R.decimal parseTagLine _ = Nothing -- | Read in a tag file from the system importTagTable :: FilePath -> IO TagTable importTagTable filename = do friendlyName <- expandTilda filename tagStr <- E.decodeUtf8 <$> BS.readFile friendlyName let cts = readCTags tagStr return TagTable { tagFileName = takeFileName filename , tagBaseDir = takeDirectory filename , tagFileMap = cts , tagCompletionTree = CT.fromList . map (_unTag) $ keys cts } -- | Gives all the possible expanded tags that could match a given @prefix@ hintTags :: TagTable -> T.Text -> [T.Text] hintTags tags prefix = map (prefix `T.append`) sufs where sufs :: [T.Text] sufs = CT.toList (CT.update (tagCompletionTree tags) prefix) -- | Extends the string to the longest certain length completeTag :: TagTable -> T.Text -> T.Text completeTag tags prefix = prefix `T.append` fst (CT.complete (CT.update (tagCompletionTree tags) prefix)) -- --------------------------------------------------------------------- -- Direct access interface to TagTable. -- | Set a new TagTable setTags :: TagTable -> EditorM () setTags = putEditorDyn . Tags . Just -- | Reset the TagTable resetTags :: EditorM () resetTags = putEditorDyn $ Tags Nothing -- | Get the currently registered tag table getTags :: EditorM (Maybe TagTable) getTags = do Tags t <- getEditorDyn return t instance Binary TagTable yi-core-0.19.4/src/Yi/TextCompletion.hs0000644000000000000000000001742607346545000016041 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.TextCompletion -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Module providing text completion functions. module Yi.TextCompletion ( -- * Word completion wordComplete, wordComplete', wordCompleteString, wordCompleteString', mkWordComplete, resetComplete, completeWordB, CompletionScope(..) ) where import Control.Monad (forM) import Data.Binary (Binary, get, put) import Data.Char (GeneralCategory (..), generalCategory) import Data.Default (Default, def) import Data.Function (on) import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) import qualified Data.Text as T (Text, drop, groupBy, head, isPrefixOf, length, null) import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8) import Data.Typeable (Typeable) import Yi.Buffer import Yi.Completion (completeInList, isCasePrefixOf) import Yi.Editor import Yi.Keymap (YiM) import qualified Yi.Rope as R (fromText, toText) import Yi.Types (YiVariable) import Yi.Utils (nubSet) -- --------------------------------------------------------------------- -- | Word completion -- -- when doing keyword completion, we need to keep track of the word -- we're trying to complete. newtype Completion = Completion [T.Text] -- the list of all possible things we can complete to. -- (this seems very inefficient; but we use laziness to -- our advantage) deriving (Typeable, Show, Eq) instance Binary Completion where put (Completion ts) = put (E.encodeUtf8 <$> ts) get = Completion . map E.decodeUtf8 <$> get -- TODO: put this in keymap state instead instance Default Completion where def = Completion [] instance YiVariable Completion -- | Switch out of completion mode. resetComplete :: EditorM () resetComplete = putEditorDyn (Completion []) -- | Try to complete the current word with occurrences found elsewhere in the -- editor. Further calls try other options. mkWordComplete :: YiM T.Text -- ^ Extract function -> (T.Text -> YiM [T.Text]) -- ^ Source function -> ([T.Text] -> YiM ()) -- ^ Message function -> (T.Text -> T.Text -> Bool) -- ^ Predicate matcher -> YiM T.Text mkWordComplete extractFn sourceFn msgFn predMatch = do Completion complList <- withEditor getEditorDyn case complList of (x:xs) -> do -- more alternatives, use them. msgFn (x:xs) withEditor . putEditorDyn $ Completion xs return x [] -> do -- no alternatives, build them. w <- extractFn ws <- sourceFn w let comps = nubSet (filter (matches w) ws) ++ [w] putEditorDyn $ Completion comps -- We put 'w' back at the end so we go back to it after seeing -- all possibilities. -- to pick the 1st possibility. mkWordComplete extractFn sourceFn msgFn predMatch where matches x y = x `predMatch` y && x/=y wordCompleteString' :: Bool -> YiM T.Text wordCompleteString' caseSensitive = mkWordComplete (withCurrentBuffer $ textRegion =<< regionOfPartB unitWord Backward) (\_ -> withEditor wordsForCompletion) (\_ -> return ()) (isCasePrefixOf caseSensitive) where textRegion = fmap R.toText . readRegionB wordCompleteString :: YiM T.Text wordCompleteString = wordCompleteString' True wordComplete' :: Bool -> YiM () wordComplete' caseSensitive = do x <- R.fromText <$> wordCompleteString' caseSensitive withEditor $ withCurrentBuffer $ flip replaceRegionB x =<< regionOfPartB unitWord Backward wordComplete :: YiM () wordComplete = wordComplete' True ---------------------------- -- Alternative Word Completion {- 'completeWordB' is an alternative to 'wordCompleteB'. 'completeWordB' offers a slightly different interface. The user completes the word using the mini-buffer in the same way a user completes a buffer or file name when switching buffers or opening a file. This means that it never guesses and completes only as much as it can without guessing. I think there is room for both approaches. The 'wordCompleteB' approach which just guesses the completion from a list of possible completion and then re-hitting the key-binding will cause it to guess again. I think this is very nice for things such as completing a word within a TeX-buffer. However using the mini-buffer might be nicer when we allow syntax knowledge to allow completion for example we may complete from a Hoogle database. -} completeWordB :: CompletionScope -> EditorM () completeWordB = veryQuickCompleteWord data CompletionScope = FromCurrentBuffer | FromAllBuffers deriving (Eq, Show) {- This is a very quick and dirty way to complete the current word. It works in a similar way to the completion of words in the mini-buffer it uses the message buffer to give simple feedback such as, "Matches:" and "Complete, but not unique:" It is by no means perfect but it's also not bad, pretty usable. -} veryQuickCompleteWord :: CompletionScope -> EditorM () veryQuickCompleteWord scope = do (curWord, curWords) <- withCurrentBuffer wordsAndCurrentWord allWords <- fmap concat $ withEveryBuffer $ words' <$> (R.toText <$> elemsB) let match :: T.Text -> Maybe T.Text match x = if (curWord `T.isPrefixOf` x) && (x /= curWord) then Just x else Nothing wordsToChooseFrom = if scope == FromCurrentBuffer then curWords else allWords preText <- completeInList curWord match wordsToChooseFrom if T.null curWord then printMsg "No word to complete" else withCurrentBuffer . insertN . R.fromText $ T.drop (T.length curWord) preText wordsAndCurrentWord :: BufferM (T.Text, [T.Text]) wordsAndCurrentWord = do curText <- R.toText <$> elemsB curWord <- fmap R.toText $ readRegionB =<< regionOfPartB unitWord Backward return (curWord, words' curText) wordsForCompletionInBuffer :: BufferM [T.Text] wordsForCompletionInBuffer = do let readTextRegion = fmap R.toText . readRegionB above <- readTextRegion =<< regionOfPartB Document Backward below <- readTextRegion =<< regionOfPartB Document Forward return $ reverse (words' above) ++ words' below wordsForCompletion :: EditorM [T.Text] wordsForCompletion = do _ :| bs <- fmap bkey <$> getBufferStack w0 <- withCurrentBuffer wordsForCompletionInBuffer contents <- forM bs $ \b -> withGivenBuffer b (R.toText <$> elemsB) return $ w0 ++ concatMap words' contents words' :: T.Text -> [T.Text] words' = filter (isJust . charClass . T.head) . T.groupBy ((==) `on` charClass) charClass :: Char -> Maybe Int charClass c = findIndex (generalCategory c `elem`) [ [ UppercaseLetter, LowercaseLetter, TitlecaseLetter , ModifierLetter, OtherLetter , ConnectorPunctuation , NonSpacingMark, SpacingCombiningMark, EnclosingMark , DecimalNumber, LetterNumber, OtherNumber ] , [ MathSymbol, CurrencySymbol, ModifierSymbol, OtherSymbol ] ] {- Finally obviously we wish to have a much more sophisticated completeword. One which spawns a mini-buffer and allows searching in Hoogle databases or in other files etc. -} yi-core-0.19.4/src/Yi/Types.hs0000644000000000000000000004574307346545000014172 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Types -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- This module is the host of the most prevalent types throughout Yi. -- It is unfortunately a necessary evil to avoid use of bootfiles. -- -- You're encouraged to import from more idiomatic modules which will -- re-export these where appropriate. module Yi.Types where import Control.Concurrent (MVar, modifyMVar, modifyMVar_, readMVar) import Control.Monad.Base (MonadBase, liftBase) import qualified Control.Monad.Fail as Fail import Control.Monad.Reader import Control.Monad.State.Strict import Control.Monad (ap, liftM3, void, forever) import qualified Data.Set as Set import Data.Binary (Binary) import qualified Data.Binary as B (get, put) import Data.Default (Default, def) import qualified Data.DelayList as DelayList (DelayList) import qualified Data.DynamicState as ConfigState (DynamicState) import qualified Data.DynamicState.Serializable as DynamicState (DynamicState) import Data.Function (on) import Data.List.NonEmpty (NonEmpty) import Data.List.PointedList (PointedList) import qualified Data.Map.Strict as M (Map) import qualified Data.Text as T (Text) import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8) import Data.Time (UTCTime (..)) import Data.Typeable (Typeable) import qualified Data.Sequence as S import Data.Word (Word8) import Yi.Buffer.Basic (BufferRef, WindowRef) import Yi.Buffer.Implementation import Yi.Buffer.Undo (URList) import Yi.Config.Misc (ScrollStyle) import Yi.Event (Event) import qualified Yi.Interact as I (I, P (End)) import Yi.KillRing (Killring) import Yi.Layout (AnyLayoutManager) import Yi.Monad (getsAndModify) import Yi.Process (SubprocessId, SubprocessInfo) import qualified Yi.Rope as R (YiString) import Yi.Style (StyleName) import Yi.Style.Library (Theme) import Yi.Syntax (ExtHL, Stroke) import Yi.Tab (Tab) import Yi.UI.Common (UI) import Yi.Window (Window) -- Yi.Keymap -- TODO: refactor this! data Action = forall a. Show a => YiA (YiM a) | forall a. Show a => EditorA (EditorM a) | forall a. Show a => BufferA (BufferM a) deriving Typeable emptyAction :: Action emptyAction = BufferA (return ()) class (Default a, Binary a, Typeable a) => YiVariable a class (Default a, Typeable a) => YiConfigVariable a instance Eq Action where _ == _ = False instance Show Action where show (YiA _) = "@Y" show (EditorA _) = "@E" show (BufferA _) = "@B" type Interact ev a = I.I ev Action a type KeymapM a = Interact Event a type Keymap = KeymapM () type KeymapEndo = Keymap -> Keymap type KeymapProcess = I.P Event Action data IsRefreshNeeded = MustRefresh | NoNeedToRefresh deriving (Show, Eq) data Yi = Yi { yiUi :: UI Editor , yiInput :: [Event] -> IO () -- ^ input stream , yiOutput :: IsRefreshNeeded -> [Action] -> IO () -- ^ output stream , yiConfig :: Config -- TODO: this leads to anti-patterns and seems like one itself -- too coarse for actual concurrency, otherwise pointless -- And MVars can be empty so this causes soundness problems -- Also makes code a bit opaque , yiVar :: MVar YiVar -- ^ The only mutable state in the program } deriving Typeable data YiVar = YiVar { yiEditor :: !Editor , yiSubprocessIdSupply :: !SubprocessId , yiSubprocesses :: !(M.Map SubprocessId SubprocessInfo) } -- | The type of user-bindable functions -- TODO: doc how these are actually user-bindable -- are they? newtype YiM a = YiM {runYiM :: ReaderT Yi IO a} deriving (Monad, Applicative, MonadReader Yi, MonadBase IO, Typeable, Functor, Fail.MonadFail) instance MonadState Editor YiM where get = yiEditor <$> (liftBase . readMVar =<< yiVar <$> ask) put v = liftBase . flip modifyMVar_ (\x -> return $ x {yiEditor = v}) =<< yiVar <$> ask instance MonadEditor YiM where askCfg = yiConfig <$> ask withEditor f = do r <- asks yiVar cfg <- asks yiConfig liftBase $ unsafeWithEditor cfg r f unsafeWithEditor :: Config -> MVar YiVar -> EditorM a -> IO a unsafeWithEditor cfg r f = modifyMVar r $ \var -> do let e = yiEditor var let (e',a) = runEditor cfg f e -- Make sure that the result of runEditor is evaluated before -- replacing the editor state. Otherwise, we might replace e -- with an exception-producing thunk, which makes it impossible -- to look at or update the editor state. -- Maybe this could also be fixed by -fno-state-hack flag? -- TODO: can we simplify this? e' `seq` a `seq` return (var {yiEditor = e'}, a) data KeymapSet = KeymapSet { topKeymap :: Keymap -- ^ Content of the top-level loop. , insertKeymap :: Keymap -- ^ For insertion-only modes } extractTopKeymap :: KeymapSet -> Keymap extractTopKeymap kms = forever (topKeymap kms) -- Note the use of "forever": this has quite subtle implications, as it means that -- failures in one iteration can yield to jump to the next iteration seamlessly. -- eg. in emacs keybinding, failures in incremental search, like , will "exit" -- incremental search and immediately move to the left. -- Yi.Buffer.Misc -- | The BufferM monad writes the updates performed. newtype BufferM a = BufferM { fromBufferM :: ReaderT Window (State FBuffer) a } deriving ( Monad, Functor, Typeable , MonadState FBuffer , MonadReader Window ) instance Fail.MonadFail BufferM where fail = error -- | Currently duplicates some of Vim's indent settings. Allowing a -- buffer to specify settings that are more dynamic, perhaps via -- closures, could be useful. data IndentSettings = IndentSettings { expandTabs :: !Bool -- ^ Insert spaces instead of tabs as possible , tabSize :: !Int -- ^ Size of a Tab , shiftWidth :: !Int -- ^ Indent by so many columns } deriving (Eq, Show, Typeable) instance Applicative BufferM where pure = return (<*>) = ap data FBuffer = forall syntax. FBuffer { bmode :: !(Mode syntax) , rawbuf :: !(BufferImpl syntax) , attributes :: !Yi.Types.Attributes } deriving Typeable instance Eq FBuffer where (==) = (==) `on` bkey__ . attributes type WinMarks = MarkSet Mark data MarkSet a = MarkSet { fromMark, insMark, selMark :: !a } deriving (Traversable, Foldable, Functor, Show) instance Binary a => Binary (MarkSet a) where put (MarkSet f i s) = B.put f >> B.put i >> B.put s get = liftM3 MarkSet B.get B.get B.get data Attributes = Attributes { ident :: !BufferId , bkey__ :: !BufferRef -- ^ immutable unique key , undos :: !URList -- ^ undo/redo list , bufferDynamic :: !DynamicState.DynamicState -- ^ dynamic components , preferCol :: !(Maybe Int) -- ^ preferred column to arrive at when we do a lineDown / lineUp , preferVisCol :: !(Maybe Int) -- ^ preferred column to arrive at visually (ie, respecting wrap) , stickyEol :: !Bool -- ^ stick to the end of line (used by vim bindings mostly) , pendingUpdates :: !(S.Seq UIUpdate) -- ^ updates that haven't been synched in the UI yet , selectionStyle :: !SelectionStyle , keymapProcess :: !KeymapProcess , winMarks :: !(M.Map WindowRef WinMarks) , lastActiveWindow :: !Window , lastSyncTime :: !UTCTime -- ^ time of the last synchronization with disk , readOnly :: !Bool -- ^ read-only flag , inserting :: !Bool -- ^ the keymap is ready for insertion into this buffer , directoryContent :: !Bool -- ^ does buffer contain directory contents , pointFollowsWindow :: !(Set.Set WindowRef) , updateTransactionInFlight :: !Bool , updateTransactionAccum :: !(S.Seq Update) , fontsizeVariation :: !Int -- ^ How many points (frontend-specific) to change -- the font by in this buffer , updateStream :: !(S.Seq Update) -- ^ Updates that we've seen in this buffer, basically -- "write-only". Work-around for broken WriterT. } deriving Typeable instance Binary Yi.Types.Attributes where put (Yi.Types.Attributes n b u bd pc pv se pu selectionStyle_ _proc wm law lst ro ins _dc _pfw isTransacPresent transacAccum fv lg') = do let putTime (UTCTime x y) = B.put (fromEnum x) >> B.put (fromEnum y) B.put n >> B.put b >> B.put u >> B.put bd B.put pc >> B.put pv >> B.put se >> B.put pu >> B.put selectionStyle_ >> B.put wm B.put law >> putTime lst >> B.put ro >> B.put ins >> B.put _dc B.put isTransacPresent >> B.put transacAccum >> B.put fv >> B.put lg' get = Yi.Types.Attributes <$> B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> B.get <*> pure I.End <*> B.get <*> B.get <*> getTime <*> B.get <*> B.get <*> B.get <*> pure ({- TODO can serialise now -}mempty) <*> B.get <*> B.get <*> B.get <*> B.get where getTime = UTCTime <$> (toEnum <$> B.get) <*> (toEnum <$> B.get) data BufferId = MemBuffer !T.Text | FileBuffer !FilePath deriving (Show, Eq, Ord) instance Binary BufferId where get = B.get >>= \case (0 :: Word8) -> MemBuffer . E.decodeUtf8 <$> B.get 1 -> FileBuffer <$> B.get x -> fail $ "Binary failed on BufferId, tag: " ++ show x put (MemBuffer t) = B.put (0 :: Word8) >> B.put (E.encodeUtf8 t) put (FileBuffer t) = B.put (1 :: Word8) >> B.put t data SelectionStyle = SelectionStyle { highlightSelection :: !Bool , rectangleSelection :: !Bool } deriving (Typeable, Show) instance Binary SelectionStyle where put (SelectionStyle h r) = B.put h >> B.put r get = SelectionStyle <$> B.get <*> B.get data AnyMode = forall syntax. AnyMode (Mode syntax) deriving Typeable -- | A Mode customizes the Yi interface for editing a particular data -- format. It specifies when the mode should be used and controls -- file-specific syntax highlighting and command input, among other -- things. data Mode syntax = Mode { modeName :: T.Text -- ^ so this can be serialized, debugged. , modeApplies :: FilePath -> R.YiString -> Bool -- ^ What type of files does this mode apply to? , modeHL :: ExtHL syntax -- ^ Syntax highlighter , modePrettify :: syntax -> BufferM () -- ^ Prettify current \"paragraph\" , modeKeymap :: KeymapSet -> KeymapSet -- ^ Buffer-local keymap modification , modeIndent :: syntax -> IndentBehaviour -> BufferM () -- ^ emacs-style auto-indent line , modeFollow :: syntax -> Action -- ^ Follow a \"link\" in the file. (eg. go to location of error message) , modeIndentSettings :: IndentSettings , modeToggleCommentSelection :: Maybe (BufferM ()) , modeGetStrokes :: syntax -> Point -> Point -> Point -> [Stroke] -- ^ Strokes that should be applied when displaying a syntax element -- should this be an Action instead? , modeOnLoad :: BufferM () -- ^ An action that is to be executed when this mode is set , modeModeLine :: [T.Text] -> BufferM T.Text -- ^ buffer-local modeline formatting method , modeGotoDeclaration :: BufferM () -- ^ go to the point where the variable is declared } -- | Used to specify the behaviour of the automatic indent command. data IndentBehaviour = IncreaseCycle -- ^ Increase the indentation to the next higher indentation -- hint. If we are currently at the highest level of -- indentation then cycle back to the lowest. | DecreaseCycle -- ^ Decrease the indentation to the next smaller indentation -- hint. If we are currently at the smallest level then -- cycle back to the largest | IncreaseOnly -- ^ Increase the indentation to the next higher hint -- if no such hint exists do nothing. | DecreaseOnly -- ^ Decrease the indentation to the next smaller indentation -- hint, if no such hint exists do nothing. deriving (Eq, Show) -- Yi.Editor type Status = ([T.Text], StyleName) type Statuses = DelayList.DelayList Status -- | The Editor state data Editor = Editor { bufferStack :: !(NonEmpty BufferRef) -- ^ Stack of all the buffers. -- Invariant: first buffer is the current one. , buffers :: !(M.Map BufferRef FBuffer) , refSupply :: !Int -- ^ Supply for buffer, window and tab ids. , tabs_ :: !(PointedList Tab) -- ^ current tab contains the visible windows pointed list. , dynamic :: !DynamicState.DynamicState -- ^ dynamic components , statusLines :: !Statuses , maxStatusHeight :: !Int , killring :: !Killring , currentRegex :: !(Maybe SearchExp) -- ^ currently highlighted regex (also most recent regex for use -- in vim bindings) , searchDirection :: !Direction , pendingEvents :: ![Event] -- ^ Processed events that didn't yield any action yet. , onCloseActions :: !(M.Map BufferRef (EditorM ())) -- ^ Actions to be run when the buffer is closed; should be scrapped. } deriving Typeable newtype EditorM a = EditorM {fromEditorM :: ReaderT Config (State Editor) a} deriving (Monad, Applicative, MonadState Editor, MonadReader Config, Functor, Typeable) instance MonadEditor EditorM where askCfg = ask withEditor = id instance Fail.MonadFail EditorM where fail = error class (Monad m, MonadState Editor m) => MonadEditor m where askCfg :: m Config withEditor :: EditorM a -> m a withEditor f = do cfg <- askCfg getsAndModify (runEditor cfg f) withEditor_ :: EditorM a -> m () withEditor_ = withEditor . void runEditor :: Config -> EditorM a -> Editor -> (Editor, a) runEditor cfg f e = let (a, e') = runState (runReaderT (fromEditorM f) cfg) e in (e',a) -- Yi.Config data UIConfig = UIConfig { configFontName :: Maybe String, -- ^ Font name, for the UI that support it. configFontSize :: Maybe Int, -- ^ Font size, for the UI that support it. configScrollStyle :: Maybe ScrollStyle, -- ^ Style of scroll configScrollWheelAmount :: Int, -- ^ Amount to move the buffer when using the scroll wheel configLeftSideScrollBar :: Bool, -- ^ Should the scrollbar be shown on the left side? configAutoHideScrollBar :: Bool, -- ^ Hide scrollbar automatically if text fits on one page. configAutoHideTabBar :: Bool, -- ^ Hide the tabbar automatically if only one tab is present configLineWrap :: Bool, -- ^ Wrap lines at the edge of the window if too long to display. configCursorStyle :: CursorStyle, configWindowFill :: Char, -- ^ The char with which to fill empty window space. Usually '~' for vi-like -- editors, ' ' for everything else. configTheme :: Theme, -- ^ UI colours configLineNumbers :: Bool -- ^ Should we show line numbers by default? } type UIBoot = Config -> ([Event] -> IO ()) -> ([Action] -> IO ()) -> Editor -> IO (UI Editor) -- | When should we use a "fat" cursor (i.e. 2 pixels wide, rather than 1)? Fat -- cursors have only been implemented for the Pango frontend. data CursorStyle = AlwaysFat | NeverFat | FatWhenFocused | FatWhenFocusedAndInserting -- | Configuration record. All Yi hooks can be set here. data Config = Config {startFrontEnd :: UIBoot, -- ^ UI to use. configUI :: !UIConfig, -- ^ UI-specific configuration. startActions :: ![Action], -- ^ Actions to run when the editor is started. initialActions :: ![Action], -- ^ Actions to run after startup (after startActions) or reload. defaultKm :: !KeymapSet, -- ^ Default keymap to use. configInputPreprocess :: !(I.P Event Event), modeTable :: ![AnyMode], -- ^ List modes by order of preference. debugMode :: !Bool, -- ^ Produce a .yi.dbg file with a lot of debug information. configRegionStyle :: !RegionStyle, -- ^ Set to 'Exclusive' for an emacs-like behaviour. configKillringAccumulate :: !Bool, -- ^ Set to 'True' for an emacs-like behaviour, where -- all deleted text is accumulated in a killring. configCheckExternalChangesObsessively :: !Bool, bufferUpdateHandler :: !(S.Seq (S.Seq Update -> BufferM ())), layoutManagers :: ![AnyLayoutManager], -- ^ List of layout managers for 'cycleLayoutManagersNext' configVars :: !ConfigState.DynamicState -- ^ Custom configuration, containing the 'YiConfigVariable's. Configure with 'configVariableA'. } -- Yi.Buffer.Normal -- Region styles are relative to the buffer contents. -- They likely should be considered a TextUnit. data RegionStyle = LineWise | Inclusive | Exclusive | Block deriving (Eq, Typeable, Show) instance Binary RegionStyle where put LineWise = B.put (0 :: Word8) put Inclusive = B.put (1 :: Word8) put Exclusive = B.put (2 :: Word8) put Block = B.put (3 :: Word8) get = B.get >>= \case (0 :: Word8) -> return LineWise 1 -> return Inclusive 2 -> return Exclusive 3 -> return Block n -> fail $ "Binary RegionStyle fail with " ++ show n -- TODO: put in the buffer state proper. instance Default RegionStyle where def = Inclusive instance YiVariable RegionStyle yi-core-0.19.4/src/Yi/UI/0000755000000000000000000000000007346545000013032 5ustar0000000000000000yi-core-0.19.4/src/Yi/UI/Common.hs0000644000000000000000000000627607346545000014631 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module Yi.UI.Common where import System.Exit (ExitCode) {- | Record presenting a frontend's interface. The functions 'layout' and 'refresh' are both run by the editor's main loop, in response to user actions and so on. Their relation is a little subtle, and is discussed here: * to see some code, look at the function @refreshEditor@ in "Yi.Core". This is the only place where 'layout' and 'refresh' are used. * the function 'layout' is responsible for updating the 'Editor' with the width and height of the windows. Some frontends, such as Pango, need to modify their internal state to do this, and will consequently change their display. This is expected. * the function 'refresh' should cause the UI to update its display with the information given in the 'Editor'. * the functionalities of 'layout' and 'refresh' overlap to some extent, in the sense that both may cause the frontend to update its display. The Yi core provides the following guarantees which the frontend may take advantage of: * in the main editor loop (i.e. in the @refreshEditor@ function), 'layout' will be run (possibly multiple times) and then 'refresh' will be run. This guarantee will hold even in the case of threading (the function @refreshEditor@ will always be run atomically, using @MVar@s). * between the last run of 'layout' and the run of 'refresh', some changes may be made to the 'Editor'. However, the text, text attributes, and (displayed) window region of all windows will remain the same. However, the cursor location may change. This guarantee allows frontends which calculate rendering of the text during the 'layout' stage to avoid recalculating the render again during 'refresh'. Pango is an example of such a frontend. The Yi core provides no guarantee about the OS thread from which the functions 'layout' and 'refresh' are called from. In particular, subprocesses (e.g. compilation, ghci) will run 'layout' and 'refresh' from new OS threads (see @startSubprocessWatchers@ in "Yi.Core"). The frontend must be prepared for this: for instance, Gtk-based frontends should wrap GUI updates in @postGUIAsync@. -} data UI e = UI { main :: IO () -- ^ Main loop , end :: Maybe ExitCode -> IO () -- ^ Clean up, and also terminate if given an exit code. , suspend :: IO () -- ^ Suspend (or minimize) the program , refresh :: e -> IO () -- ^ Refresh the UI with the given state , userForceRefresh :: IO () -- ^ User force-refresh (in case the screen has been messed up from outside) , layout :: e -> IO e -- ^ Set window width and height , reloadProject :: FilePath -> IO () -- ^ Reload cabal project views } dummyUI :: UI e dummyUI = UI { main = return () , end = const (return ()) , suspend = return () , refresh = const (return ()) , userForceRefresh = return () , layout = return , reloadProject = const (return ()) } yi-core-0.19.4/src/Yi/UI/LineNumbers.hs0000644000000000000000000000271107346545000015612 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.UI.LineNumbers -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Line numbers. module Yi.UI.LineNumbers ( getDisplayLineNumbersLocal , setDisplayLineNumbersLocal ) where import Data.Binary (Binary (..)) import Data.Default (Default (..)) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Yi.Buffer (getBufferDyn, putBufferDyn) import Yi.Types (BufferM, YiVariable) newtype DisplayLineNumbersLocal = DisplayLineNumbersLocal { unDisplayLineNumbersLocal :: Maybe Bool } deriving (Generic, Typeable) instance Default DisplayLineNumbersLocal where def = DisplayLineNumbersLocal Nothing instance Binary DisplayLineNumbersLocal instance YiVariable DisplayLineNumbersLocal -- | Get the buffer-local line number setting. getDisplayLineNumbersLocal :: BufferM (Maybe Bool) getDisplayLineNumbersLocal = unDisplayLineNumbersLocal <$> getBufferDyn -- | Set the buffer-local line number setting. -- Nothing: use global setting -- Just True: display line numbers only in this buffer -- Just False: hide line numbers only in this buffer setDisplayLineNumbersLocal :: Maybe Bool -> BufferM () setDisplayLineNumbersLocal = putBufferDyn . DisplayLineNumbersLocal yi-core-0.19.4/src/Yi/UI/SimpleLayout.hs0000644000000000000000000001637507346545000016031 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Yi.UI.SimpleLayout ( Rect (..) , Layout (..) , Point2D (..) , Size2D (..) , coordsOfCharacterB , layout , verticalOffsetsForWindows ) where import Prelude hiding (concatMap, mapM) import Lens.Micro.Platform (use, (.~), (&), (^.), to, _1) import Control.Monad.State (evalState, get, put) import Data.Foldable (find, toList) import qualified Data.List.PointedList.Circular as PL (PointedList, focus) import qualified Data.Map.Strict as M (Map, fromList) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T (uncons) import Data.Traversable (mapM) import Yi.Buffer import Yi.Editor import qualified Yi.Rope as R (take, toString, toText) import Yi.UI.Utils (arrangeItems) import Yi.Window import Yi.Tab (tabLayout) import Yi.Layout (Rectangle(..), HasNeighborWest, layoutToRectangles) data Layout = Layout { tabbarRect :: !Rect , windowRects :: !(M.Map WindowRef (Rect, HasNeighborWest)) , promptRect :: !Rect } data Rect = Rect { offsetX :: !Int , offsetY :: !Int , sizeX :: !Int , sizeY :: !Int } data Point2D = Point2D { pointCol :: !Int , pointRow :: !Int } data Size2D = Size2D { sizeWidth :: !Int , sizeHeight :: !Int } layout :: Int -> Int -> Editor -> (Editor, Layout) layout colCount rowCount e = ( e & windowsA .~ newWs , Layout tabRect winRects cmdRect ) where lt = e ^. tabsA . PL.focus . to tabLayout miniWs = filter isMini . toList $ windows e tabHeight = 1 tabRect = Rect 0 0 colCount tabHeight cmdHeight = length $ arrangeItems (fst $ statusLineInfo e) colCount (maxStatusHeight e) miniHeight = if null miniWs then 0 else 1 cmdRect = Rect 0 (rowCount - cmdHeight - miniHeight) colCount cmdHeight bounds = rectToRectangle $ Rect 0 tabHeight colCount $ rowCount - (max 1 $ cmdHeight + miniHeight) - tabHeight bigRects = layoutToRectangles False bounds lt & map (\(wr, r, nb) -> let r' = rectangleToRect r sx = sizeX r' - if nb then 1 else 0 w' = layoutWindow (findWindowWith wr e) e sx (sizeY r') in (w', r', nb)) miniRects = miniWs & map (\w -> let r' = Rect 0 (rowCount - 1) colCount 1 w' = layoutWindow w e (sizeX r') (sizeY r') in (w', r', False)) rects = bigRects <> miniRects winRects = rects & M.fromList . map (\(w, r, nb) -> (wkey w, (r, nb))) updWs = rects & map (^. _1) newWs = windows e & fmap (\w -> fromMaybe w $ find ((== wkey w) . wkey) updWs) rectToRectangle :: Rect -> Rectangle rectToRectangle (Rect x y sx sy) = Rectangle (fromIntegral x) (fromIntegral y) (fromIntegral sx) (fromIntegral sy) rectangleToRect :: Rectangle -> Rect rectangleToRect (Rectangle x y sx sy) = Rect (truncate x) (truncate y) (truncate (x + sx) - truncate x) (truncate (y + sy) - truncate y) layoutWindow :: Window -> Editor -> Int -> Int -> Window layoutWindow win e w h = win { height = h , width = w , winRegion = mkRegion fromMarkPoint toMarkPoint , actualLines = dispLnCount } where b = findBufferWith (bufkey win) e evalBuffer action = fst (runBuffer win b action) -- Mini windows don't have a mode line. h' = h - if isMini win then 0 else 1 -- Work around a problem with the mini window never displaying it's contents due to a -- fromMark that is always equal to the end of the buffer contents. Just (MarkSet fromM _ _) = evalBuffer (getMarks win) fromMarkPoint = if isMini win then Point 0 else evalBuffer $ use $ markPointA fromM -- TODO: I suspect that this costs quite a lot of CPU in the "dry run" which determines the window size; -- In that case, since attributes are also useless there, it might help to replace the call by a dummy value. -- This is also approximately valid of the call to "indexedAnnotatedStreamB". (toMarkPoint, wrapCount) = evalBuffer (lastVisiblePointAndWrapCountB (Size2D w h') fromMarkPoint) dispLnCount = h' - wrapCount coordsOfCharacterB :: Size2D -> Point -> Point -> BufferM (Maybe Point2D) coordsOfCharacterB _ topLeft char | topLeft > char = return Nothing coordsOfCharacterB (Size2D w h) (Point topLeft) (Point char) | char - topLeft >= w * h = return Nothing coordsOfCharacterB (Size2D w h) (Point topLeft) (Point char) = savingPointB $ do ts <- fmap tabSize indentSettingsB text <- fmap (R.toString . R.take (w * h)) (streamB Forward (Point topLeft)) let go _ !y _ _ | y >= h = Nothing go !x !y 0 _ = Just (Point2D x y) go !x !y !n (c : d : t) = case (c, d, compare x wOffset) of ('\t', _ , _) -> go (x + ts) y (n - 1) (d:t) ('\n', _ , _) -> go 0 (y + 1) (n - 1) (d:t) ( _ ,'\n',EQ) -> go x y (n - 1) (d:t) ( _ , _ ,EQ) -> go (x - wOffset) (y + 1) (n - 1) (d:t) ( _ , _ , _) -> go (x + 1) y (n - 1) (d:t) where wOffset = w - 1 go !x !y !n [c] = case (c, compare x wOffset) of ('\n', _) -> go 0 (y + 1) (n - 1) [c] ( _ , _) -> go (x + 1) y (n - 1) [c] where wOffset = w - 1 go !x !y _ _ = Just (Point2D x y) return (go 0 0 (char - topLeft) text) lastVisiblePointAndWrapCountB :: Size2D -> Point -> BufferM (Point, Int) lastVisiblePointAndWrapCountB (Size2D w h) (Point topLeft) = savingPointB $ do ts <- fmap tabSize indentSettingsB text <- fmap (R.toText . R.take (w * h)) (streamB Forward (Point topLeft)) let go !x !y !wc !n t | x > w = go (x - w) (y + 1) (wc + 1) n t go _ !y !wc !n _ | y >= h = (Point (n - 1), wc) go !x !y !wc !n (T.uncons -> Just (c, t)) = case c of '\t' -> go (x + ts) y wc (n + 1) t '\n' -> go 0 (y + 1) wc (n + 1) t _ -> go (x + 1) y wc (n + 1) t go _ _ !wc !n _ = (Point n, wc) return (go 0 0 0 topLeft text) verticalOffsetsForWindows :: Int -> PL.PointedList Window -> PL.PointedList Int verticalOffsetsForWindows startY ws = scanrT (+) startY (fmap (\w -> if isMini w then 0 else height w) ws) -- As scanr, but generalized to a traversable (TODO) scanrT :: (Int -> Int -> Int) -> Int -> PL.PointedList Int -> PL.PointedList Int scanrT (+*+) k t = evalState (mapM f t) k where f x = do s <- get let s' = s +*+ x put s' return s yi-core-0.19.4/src/Yi/UI/TabBar.hs0000644000000000000000000000402007346545000014515 0ustar0000000000000000{-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.UI.TabBar -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Tabs. module Yi.UI.TabBar where import Lens.Micro.Platform ((^.)) import qualified Data.List.PointedList.Circular as PL (PointedList (_focus), withFocus) import qualified Data.Text as T (Text, pack, unpack) import System.FilePath (isValid, splitPath) import Yi.Buffer (shortIdentString) import Yi.Editor (Editor (..), commonNamePrefix, findBufferWith, tabsA) import Yi.Tab (tabWindowsA) import Yi.Window (Window (bufkey)) -- | A TabDescr describes the properties of a UI tab independent of -- the particular GUI in use. data TabDescr = TabDescr { tabText :: T.Text , tabInFocus :: Bool } deriving (Show, Eq) type TabBarDescr = PL.PointedList TabDescr tabBarDescr :: Editor -> TabBarDescr tabBarDescr editor = tabDescr <$> PL.withFocus (editor ^. tabsA) where prefix = commonNamePrefix editor shorten = tabAbbrevTitle . shortIdentString (length prefix) mkHintWith f = shorten $ findBufferWith f editor hintForTab tab = mkHintWith (bufkey $ PL._focus (tab ^. tabWindowsA)) tabDescr (tab, True) = TabDescr (hintForTab tab) True tabDescr (tab, False) = TabDescr (hintForTab tab) False -- FIXME: it seems that using splitDirectories can abstract the '/' -- handling away. (Making it win32 friendly and simpler) tabAbbrevTitle :: T.Text -> T.Text tabAbbrevTitle title = if isValid fp then T.pack $ concatMap abbrev (splitPath fp) else title where fp = T.unpack title abbrev "/" = "/" abbrev path | head path == '.' && last path == '/' = take 2 path ++ "/" | last path == '/' = head path : "/" | otherwise = path yi-core-0.19.4/src/Yi/UI/Utils.hs0000644000000000000000000001213407346545000014467 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.UI.Utils -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Utilities shared by various UIs module Yi.UI.Utils where import Prelude hiding (mapM) import Control.Arrow (second) import Lens.Micro.Platform (use) import Control.Monad.State (evalState, modify) import Control.Monad.State.Class (gets) import Data.Foldable (maximumBy) import Data.Function (on) import Data.List (transpose) import Data.List.Split (chunksOf) import Data.Monoid (Endo (appEndo)) import qualified Data.Text as T (Text, null, pack, unpack) import Data.Traversable (mapM) import Yi.Buffer import Yi.String (padLeft) import Yi.Style (Attributes, StyleName, UIStyle (baseAttributes, selectedStyle)) import Yi.Syntax (Span (..)) import Yi.Window (Window (height, isMini)) applyHeights :: Traversable t => [Int] -> t Window -> t Window applyHeights heights ws = evalState (mapM distribute ws) heights where distribute win = if isMini win then return win{height = 1} else (do h <- gets head modify tail return win{height = h}) spliceAnnots :: [(Point,Char)] -> [Span String] -> [(Point,Char)] spliceAnnots text [] = text spliceAnnots text (Span start x stop:anns) = l ++ zip (repeat start) x ++ spliceAnnots r anns where (l,rest) = span ((start >) . fst) text (_,r) = span ((stop >) . fst) rest -- | Turn a sequence of (from,style,to) strokes into a sequence -- of picture points (from,style), taking special care to -- ensure that the points are strictly increasing and introducing -- padding segments where necessary. -- Precondition: Strokes are ordered and not overlapping. strokePicture :: [Span (Endo a)] -> [(Point,a -> a)] strokePicture [] = [] strokePicture wholeList@(Span leftMost _ _:_) = helper leftMost wholeList where helper :: Point -> [Span (Endo a)] -> [(Point,a -> a)] helper prev [] = [(prev,id)] helper prev (Span l f r:xs) | prev < l = (prev, id) : (l,appEndo f) : helper r xs | otherwise = (l,appEndo f) : helper r xs -- | Paint the given stroke-picture on top of an existing picture paintStrokes :: (a -> a) -> a -> [(Point,a -> a)] -> [(Point,a)] -> [(Point,a)] paintStrokes f0 _ [] lx = fmap (second f0) lx paintStrokes _ x0 lf [] = fmap (second ($ x0)) lf paintStrokes f0 x0 lf@((pf,f):tf) lx@((px,x):tx) = case pf `compare` px of LT -> (pf, f x0):paintStrokes f x0 tf lx EQ -> (pf, f x ):paintStrokes f x tf tx GT -> (px, f0 x ):paintStrokes f0 x lf tx paintPicture :: a -> [[Span (Endo a)]] -> [(Point,a)] paintPicture a = foldr (paintStrokes id a . strokePicture) [] attributesPictureB :: UIStyle -> Maybe SearchExp -> Region -> [[Span StyleName]] -> BufferM [(Point,Attributes)] attributesPictureB sty mexp region extraLayers = paintPicture (baseAttributes sty) <$> fmap (fmap (fmap ($ sty))) <$> (extraLayers ++) <$> strokesRangesB mexp region attributesPictureAndSelB :: UIStyle -> Maybe SearchExp -> Region -> BufferM [(Point,Attributes)] attributesPictureAndSelB sty mexp region = do selReg <- getSelectRegionB showSel <- use highlightSelectionA rectSel <- use rectangleSelectionA let styliseReg reg = Span (regionStart reg) selectedStyle (regionEnd reg) extraLayers | rectSel && showSel = (:[]) . fmap styliseReg <$> blockifyRegion selReg | showSel = return [[styliseReg selReg]] | otherwise = return [] attributesPictureB sty mexp region =<< extraLayers -- | Arrange a list of items in columns over maximum @maxNumberOfLines@ lines arrangeItems :: [T.Text] -> Int -> Int -> [T.Text] arrangeItems items _ _ | all T.null items = [] arrangeItems items maxWidth maxNumberOfLines = take maxNumberOfLines $ snd choice where choice = maximumBy (compare `on` fst) arrangements arrangements = fmap (arrangeItems' items maxWidth) (reverse [1..maxNumberOfLines]) -- | Arrange a list of items in columns over @numberOfLines@ lines. -- -- TODO: proper Text/YiString implementation arrangeItems' :: [T.Text] -> Int -> Int -> (Int, [T.Text]) arrangeItems' items' maxWidth numberOfLines = (fittedItems,theLines) where items = T.unpack <$> items' columns = chunksOf numberOfLines items columnsWidth = fmap (maximum . fmap length) columns totalWidths = scanl (\x y -> 1 + x + y) 0 columnsWidth shownItems = scanl (+) 0 (fmap length columns) fittedItems = snd $ last $ takeWhile ((<= maxWidth) . fst) $ zip totalWidths shownItems theLines = T.pack . unwords . zipWith padLeft columnsWidth <$> transpose columns yi-core-0.19.4/src/Yi/Window.hs0000644000000000000000000000547607346545000014334 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Window -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- -- Operations on 'Window's, in the emacs sense of the word. module Yi.Window where import Data.Binary (Binary (..)) import Data.Default (Default (def)) import Data.Typeable (Typeable) import Yi.Buffer.Basic (BufferRef, WindowRef) import Yi.JumpList (JumpList) import Yi.Region (Region, emptyRegion) import Yi.Utils (makeLensesWithSuffix) ------------------------------------------------------------------------ -- | A window onto a buffer. data Window = Window { isMini :: !Bool -- ^ regular or mini window? , bufkey :: !BufferRef -- ^ the buffer this window opens to , bufAccessList :: ![BufferRef] -- ^ list of last accessed buffers (former bufKeys). Last -- accessed one is first element , height :: !Int -- ^ height of the window (in number of screen -- lines displayed) , width :: !Int -- ^ width of the window (in number of chars) , winRegion :: !Region -- ^ view area. note that the top point is -- also available as a buffer mark. , wkey :: !WindowRef -- ^ identifier for the window (for UI sync) -- This is required for accurate scrolling. -- Scrolling depends on the actual number of buffer -- lines displayed. Line wrapping changes that number -- relative to the height so we can't use height for that -- purpose. , actualLines :: !Int -- ^ The actual number of buffer lines displayed. Taking into -- account line wrapping , jumpList :: !JumpList } deriving (Typeable) makeLensesWithSuffix "A" ''Window instance Binary Window where put (Window mini bk bl _w _h _rgn key lns jl) = put mini >> put bk >> put bl >> put key >> put lns >> put jl get = Window <$> get <*> get <*> get <*> return 0 <*> return 0 <*> return emptyRegion <*> get <*> get <*> get -- | Get the identification of a window. winkey :: Window -> (Bool, BufferRef) winkey w = (isMini w, bufkey w) instance Show Window where show w = "Window to " ++ show (bufkey w) -- ++ "{" ++ show (tospnt w) ++ "->" ++ show (bospnt w) ++ "}" ++ "(" ++ show (height w) ++ ")" instance Eq Window where (==) w1 w2 = wkey w1 == wkey w2 {- -- | Is a given point within tospnt / bospnt? pointInWindow :: Point -> Window -> Bool pointInWindow point win = tospnt win <= point && point <= bospnt win -} -- | Return a "fake" window onto a buffer. dummyWindow :: BufferRef -> Window dummyWindow b = Window False b [] 0 0 emptyRegion def 0 Nothing yi-core-0.19.4/test/0000755000000000000000000000000007346545000012324 5ustar0000000000000000yi-core-0.19.4/test/Spec.hs0000644000000000000000000000074107346545000013554 0ustar0000000000000000import Test.Tasty import qualified Yi.CompletionTreeTests as CompletionTree (testSuite) import qualified Yi.CompletionTests as Completion (testSuite) import qualified Yi.TagTests as Tag (testSuite) import qualified Yi.Mode.CommonTests as Mode.Common (testSuite) main :: IO () main = defaultMain tests tests :: TestTree tests = testGroup "all" [ Completion.testSuite , CompletionTree.testSuite , Tag.testSuite , Mode.Common.testSuite ] yi-core-0.19.4/test/Yi/0000755000000000000000000000000007346545000012705 5ustar0000000000000000yi-core-0.19.4/test/Yi/CompletionTests.hs0000644000000000000000000000200707346545000016374 0ustar0000000000000000module Yi.CompletionTests (testSuite) where import Data.Maybe(isJust) import Data.Monoid import Data.Text.Arbitrary() import Test.Tasty import Test.Tasty.QuickCheck import Yi.Completion as C import qualified Data.Text as T testSuite :: TestTree testSuite = testGroup "Completion" [propertyTests] propertyTests :: TestTree propertyTests = testGroup "properties" [ testProperty "infixUptoEndMatch needle (pre <> needle <> post) == Just (needle <> post) if needle and post not empty and needle not in pre" $ \pre needle post -> not (needle `T.isInfixOf` pre) ==> not (T.null post) ==> infixUptoEndMatch needle (pre <> needle <> post) == Just (needle <> post) , testProperty "infixUptoEndMatch \"\" x == Just x" $ \x -> infixUptoEndMatch T.empty x == Just x , testProperty "isJust (infixUptoEndMatch needle haystack) == needle `Data.Text.isInfixOf` haystack" $ \needle haystack -> isJust (infixUptoEndMatch needle haystack) == needle `T.isInfixOf` haystack ] yi-core-0.19.4/test/Yi/CompletionTreeTests.hs0000644000000000000000000000500307346545000017213 0ustar0000000000000000module Yi.CompletionTreeTests (testSuite) where import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.Tasty import Yi.CompletionTree as CT import qualified Data.Map as M import Data.List (sort,nub) testSuite :: TestTree testSuite = testGroup "CompletionTree" [propertyTests, unitTests] propertyTests :: TestTree propertyTests = testGroup "properties" [ testProperty "CT.toList . CT.fromList == nub . sort" $ \list -> CT.toList (CT.fromList list) == sort (nub (list :: [String])) , testProperty "update (fromList [a]) a == fromList [mempty] (a is a non-empty string)" $ \string -> null string || CT.update (CT.fromList [string :: String]) string == CT.fromList [mempty] , testProperty "\"\" `elem` update (fromList [a,...]) a" $ \listOfStrings -> null listOfStrings || null (head listOfStrings) || "" `elem` CT.toList (CT.update (CT.fromList listOfStrings) (head listOfStrings)) , testProperty "complete (fromList [a]) == (a, fromList [\"\"])" $ \string -> CT.complete (CT.fromList [string]) == (string,CT.fromList [""]) ] unitTests :: TestTree unitTests = testGroup "unit tests" [ testGroup "fromList" [ testCase "returns an empty CompletionTree when given an empty list" $ CT.fromList [] @?= (mempty :: CT.CompletionTree String) , testCase "returns a map with one key when given a list with one item" $ CT.fromList ["a"] @?= CT.CompletionTree (M.fromList [("a",mempty)]) , testCase "groups elements with the same prefix" $ CT.fromList ["aa","ab"] @?= CT.CompletionTree (M.fromList [("a",CT.CompletionTree $ M.fromList [("a",mempty),("b",mempty)])]) ] , testGroup "update" -- toList is covered by the SmallCheck and QuickCheck [ testCase "strips its argument from a matching key" $ CT.update (CT.fromList ["abc"]) "a" @?= CT.fromList ["bc"] , testCase "descends the tree if a substring of its input is found in the CompletionTree" $ CT.update (CT.fromList ["put","putStr"]) "putS" @?= CT.fromList ["tr"] , testCase "returns an empty list if it can't find a matching key" $ CT.update (CT.fromList ["put"]) "list" @?= CT.fromList [] ] , testGroup "complete" [ testCase "Returns the common prefix" $ CT.complete (CT.fromList ["put","putStr","putStrLn"]) @?= ("put",CT.fromList ["","Str","StrLn"]) , testCase "Returns an empty string if there's no common prefix" $ CT.complete (CT.fromList ["put","putStr","abc"]) @?= ("",CT.fromList ["put","putStr","abc"]) ] ] yi-core-0.19.4/test/Yi/Mode/0000755000000000000000000000000007346545000013571 5ustar0000000000000000yi-core-0.19.4/test/Yi/Mode/CommonTests.hs0000644000000000000000000000214707346545000016404 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Yi.Mode.CommonTests (testSuite) where import Test.Tasty import Test.Tasty.HUnit import Yi.Mode.Common import Data.Attoparsec.Text (parseOnly) import Control.Applicative ((<|>)) import Data.Either (isRight) testSuite :: TestTree testSuite = testGroup "Mode.Common" [unitTests] unitTests :: TestTree unitTests = testGroup "unit tests" [ testGroup "shebangParser" $ [ testCase "matches a simple shebang" $ parseOnly (shebangParser "runhaskell") "#!/usr/bin/env runhaskell\n" @?= Right () , testCase "matches a complex shebang" $ map (parseOnly (shebangParser ("python" *> ("3" <|> "2" <|> "")))) ["#!/usr/bin/env python\n", "#!/usr/bin/env python2\n", "#!/usr/bin/env python3\n"] @?= [Right (), Right (), Right ()] , testCase "ignores noise and spaces" $ parseOnly (shebangParser "runhaskell") "\n#!abcdefg\r\nABCdefG\n#! /usr/bin/env runhaskell \r\n\n/AbcDe#!/fg\n" @?= Right () , testCase "parser fails correctly" $ isRight (parseOnly (shebangParser "runhaskell") "#!/usr/bin/env abc\n") @?= False ] ] yi-core-0.19.4/test/Yi/TagTests.hs0000644000000000000000000000614107346545000015001 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Yi.TagTests (testSuite) where import Test.Tasty import Test.Tasty.HUnit import Yi.Tag import qualified Yi.CompletionTree as CT import Data.List (sort) import Data.Map (keys) testSuite :: TestTree testSuite = testGroup "Tag" [unitTests] exampleTagTable :: TagTable exampleTagTable = TagTable { tagFileName = "exampleFileName" , tagBaseDir = "." , tagFileMap = cts , tagCompletionTree = CT.fromList . map (_unTag) $ keys cts } where cts = readCTags $ "!_TAG_FILE_SORTED 1 ~\n\ \Tag src/Yi/Tag.hs 73;\" t\n\ \Tag src/Yi/Tag.hs 73;\" C\n\ \Tag src/Yi/Tag.hs 20;\" m\n\ \TagTable src/Yi/Tag.hs 82;\" t\n\ \TagTable src/Yi/Tag.hs 82;\" C\n\ \Tags src/Yi/Tag.hs 66;\" t\n\ \Tags src/Yi/Tag.hs 66;\" C\n\ \TagsFileList src/Yi/Tag.hs 53;\" t\n\ \TagsFileList src/Yi/Tag.hs 53;\" C\n\ \_unTag src/Yi/Tag.hs 73;\" f\n\ \_unTagsFileList src/Yi/Tag.hs 53;\" f\n\ \completeTag src/Yi/Tag.hs 134;\" f\n\ \getTags src/Yi/Tag.hs 151;\" f\n\ \hintTags src/Yi/Tag.hs 127;\" f\n\ \importTagTable src/Yi/Tag.hs 115;\" f\n\ \lookupTag src/Yi/Tag.hs 97;\" f\n\ \readCTags src/Yi/Tag.hs 104;\" f\n\ \resetTags src/Yi/Tag.hs 147;\" f\n\ \setTags src/Yi/Tag.hs 143;\" f\n\ \tagBaseDir src/Yi/Tag.hs 86;\" f\n\ \tagCompletionTree src/Yi/Tag.hs 91;\" f\n\ \tagFileMap src/Yi/Tag.hs 89;\" f\n\ \tagFileName src/Yi/Tag.hs 83;\" f\n\ \tagsFileList src/Yi/Tag.hs 63;\" f\n\ \unTag' src/Yi/Tag.hs 75;\" f" unitTests :: TestTree unitTests = testGroup "unit tests" [ testGroup "lookupTag" $ [ testCase "finds a tag in a taglist" $ lookupTag (Tag "Tag") exampleTagTable @?= sort [("./src/Yi/Tag.hs", 73),("./src/Yi/Tag.hs",73),("./src/Yi/Tag.hs",20)] , testCase "returns an empty list if no tag is found" $ lookupTag (Tag "") exampleTagTable @?= [] ] , testGroup "hintTags" $ [ testCase "completes the input with all possible tags" $ hintTags exampleTagTable "Tag" @?= ["Tag", "TagTable", "Tags", "TagsFileList"] , testCase "returns an empty list if the input is not a prefix of any tag" $ hintTags exampleTagTable "FooBar" @?= [] ] , testGroup "completeTag" $ [ testCase "extends the input to the longest certain length" $ completeTag exampleTagTable "_" @?= "_unTag" , testCase "returns the input when there are no completions possible" $ completeTag exampleTagTable "FooBar" @?= "FooBar" ] ] yi-core-0.19.4/yi-core.cabal0000644000000000000000000000723207346545000013704 0ustar0000000000000000name: yi-core version: 0.19.4 synopsis: Yi editor core library category: Yi homepage: https://github.com/yi-editor/yi#readme bug-reports: https://github.com/yi-editor/yi/issues maintainer: Yi developers license: GPL-2 build-type: Simple cabal-version: >= 1.10 source-repository head type: git location: https://github.com/yi-editor/yi flag hint description: Build with hint (haskell interpreter) manual: True default: False library hs-source-dirs: src ghc-options: -Wall -ferror-spans -Wall -fno-warn-orphans -ferror-spans build-depends: base >= 4.8 && < 5 , array , attoparsec , binary >= 0.7 , bytestring >= 0.9.1 , containers , data-default , directory , dlist >= 0.4.1 , dynamic-state >= 0.1.0.5 , filepath >= 1.1 , hashable >= 1.1.2.5 , ListLike >= 4.5 , microlens-platform , mtl >= 0.1.0.1 , old-locale , oo-prototypes , parsec >= 3.0 , pointedlist >= 0.5 , process >= 1.0.1.1 , process-extras >= 0.3.3.8 , split >= 0.2 , text >= 1.1.1.3 , time >= 1.1 , transformers-base , unix-compat >= 0.1 , unordered-containers >= 0.1.3 , xdg-basedir >= 0.2.1 , yi-language >= 0.19 , yi-rope >= 0.10 , exceptions if flag(hint) cpp-options: -DHINT build-depends: hint > 0.3.1 if os(win32) build-depends: Win32 else build-depends: unix exposed-modules: Yi Yi.Buffer Yi.Buffer.HighLevel Yi.Buffer.Indent Yi.Buffer.Normal Yi.Buffer.Misc Yi.Buffer.Region Yi.Buffer.TextUnit Yi.Buffer.Undo Yi.Command Yi.Command.Help Yi.Completion Yi.CompletionTree Yi.Config Yi.Config.Default Yi.Config.Misc Yi.Config.Lens Yi.Config.Simple Yi.Config.Simple.Types Yi.Core Yi.Debug Yi.Dired Yi.Editor Yi.Eval Yi.Event Yi.File Yi.History Yi.Hoogle Yi.Hooks Yi.IncrementalParse Yi.Interact Yi.JumpList Yi.Keymap Yi.Keymap.Keys Yi.KillRing Yi.Layout Yi.MiniBuffer Yi.Misc Yi.Mode.Common Yi.Mode.Compilation Yi.Mode.Interactive Yi.Monad Yi.Paths Yi.PersistentState Yi.Process Yi.Rectangle Yi.Search Yi.Search.Internal Yi.String Yi.Syntax.Driver Yi.Syntax.Layout Yi.Syntax.OnlineTree Yi.Syntax.Tree Yi.Tab Yi.Tag Yi.TextCompletion Yi.Types Yi.UI.Common Yi.UI.LineNumbers Yi.UI.SimpleLayout Yi.UI.TabBar Yi.UI.Utils Yi.Window System.FriendlyPath Parser.Incremental Paths_yi_core other-modules: Control.Exc Data.DelayList System.CanonicalizePath Yi.Buffer.Implementation default-language: Haskell2010 test-suite tasty type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test ghc-options: -Wall -ferror-spans build-depends: base >= 4.8 && < 5 , yi-rope >= 0.10 , attoparsec , tasty , tasty-hunit , tasty-quickcheck , quickcheck-text , yi-core , text , containers other-modules: Yi.CompletionTests Yi.CompletionTreeTests Yi.Mode.CommonTests Yi.TagTests default-language: Haskell2010 benchmark all type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench ghc-options: -Wall -ferror-spans -Wall -ferror-spans -rtsopts build-depends: base >= 4.8 && < 5 , yi-core , yi-rope >= 0.10 , criterion , deepseq default-language: Haskell2010