packages feed

yi-core (empty) → 0.13

raw patch · 81 files changed

+16169/−0 lines, 81 filesdep +Hclipdep +ListLikedep +QuickChecksetup-changed

Dependencies added: Hclip, ListLike, QuickCheck, Win32, array, attoparsec, base, binary, bytestring, containers, data-default, directory, dlist, dynamic-state, dyre, exceptions, filepath, hashable, hint, microlens-platform, mtl, old-locale, oo-prototypes, parsec, pointedlist, process, process-extras, random, safe, semigroups, split, tasty, tasty-hunit, tasty-quickcheck, text, text-icu, time, transformers-base, unix, unix-compat, unordered-containers, word-trie, xdg-basedir, yi-core, yi-language, yi-rope

Files

+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main :: IO ()+main = defaultMain
+ src/Control/Exc.hs view
@@ -0,0 +1,23 @@+{-# 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
+ src/Data/DelayList.hs view
@@ -0,0 +1,25 @@+-- 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
+ src/Parser/Incremental.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++-- 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 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 Profile = PSusp | PFail | PRes Int | !Int :> Profile+    deriving Show++mapSucc :: Profile -> Profile+mapSucc PSusp = PSusp+mapSucc PFail = PFail+mapSucc (PRes x) = PRes (succ x)+mapSucc (x :> xs) = succ x :> mapSucc xs++-- 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) = mapSucc (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)) = f a :< r++-- | Right-eval a fully defined process (ie. one that has no Sus)+evalR' :: Steps s r -> (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+    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) = \fut -> Sus (toP a fut) (\s -> toP (f s) fut)+toP (Appl f x) = App . toP f . toP x+toP (Pure x)   = Val x+toP Empt = const Fail+toP (Disj a b)  = \fut -> iBest (toP a fut) (toP b fut)+toP (Bind p a2q) = \fut -> toQ p (\(_,a) -> toP (a2q a) fut) ()+toP (Yuck p) = Dislike . toP p+toP (Enter err p) = Log err . toP p+toP (Shif p) = 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 :< ())
+ src/System/CanonicalizePath.hs view
@@ -0,0 +1,104 @@+{-# 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+  , normalisePath+  , 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)++-- | Removes `/./` `//` and `/../` sequences from path,+-- doesn't follow symlinks+normalisePath :: FilePath -> IO FilePath+normalisePath path = do+  absPath <- makeAbsolute path+  return $ foldl combinePath "/" $ splitPath absPath++-- | 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
+ src/System/FriendlyPath.hs view
@@ -0,0 +1,34 @@+module System.FriendlyPath+  ( userToCanonPath+  , expandTilda+  , isAbsolute'+  ) where++import System.CanonicalizePath (canonicalizePath)+import System.Directory        (getHomeDirectory)+import System.FilePath         (isAbsolute, normalise, pathSeparator)+import System.PosixCompat.User (getUserEntryForName, homeDirectory)+++-- 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+  -- 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+expandTilda path = return path++-- | Is a user-friendly path absolute?+isAbsolute' :: String -> Bool+isAbsolute' ('~':_) = True+isAbsolute' p = isAbsolute p++
+ src/Yi.hs view
@@ -0,0 +1,55 @@+{-# 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 confguration 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.Boot,+    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.Boot+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.Library
+ src/Yi/Boot.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Boot+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Boot process of Yi.+--+-- Uses Dyre to implement the XMonad-style dynamic reconfiguration.++module Yi.Boot (yi, yiDriver, yiDriver', reload) where++import qualified Config.Dyre as Dyre+import qualified Config.Dyre.Options as Dyre+import qualified Config.Dyre.Params as Dyre+import           Config.Dyre.Relaunch+import           Lens.Micro.Platform+import           Data.Text ()+import qualified Data.Text.IO as T (putStrLn)+import           System.Environment+import           System.Exit+import           Yi.Boot.Internal+import           Yi.Buffer.Misc (BufferId(..))+import           Yi.Config+import           Yi.Editor+import           Yi.Keymap+import           Yi.Main+import           Yi.Option (OptionError(..))+import           Yi.Paths (getCustomConfigPath)+import           Yi.Rope (fromString)++-- | Once the custom yi is compiled this restores the editor state (if+-- requested) then proceeds to run the editor.+realMain :: (Config, ConsoleConfig) -> IO ()+realMain configs = restoreBinaryState Nothing >>= main configs++-- | If the custom yi compile produces errors or warnings then the+-- messages are presented as a separate activity in the editor.+--+-- The use of a separate activity prevents any other initial actions+-- from immediately masking the output.+showErrorsInConf :: (Config, ConsoleConfig) -> String -> (Config, ConsoleConfig)+showErrorsInConf c errs = c & _1 . initialActionsA %~ (makeAction openErrBuf :)+  where+    openErrBuf = splitE >> newBufferE (MemBuffer "*errors*") (fromString errs)++-- | Handy alias for 'yiDriver'.+yi :: Config -> IO ()+yi = yiDriver++-- | Called from the yi built with the user's configuration. Does not+-- ignore unknown arguments.+yiDriver :: Config -> IO ()+yiDriver = yiDriver' False++-- | Used by both the yi executable and the custom yi that is built+-- from the user's configuration. The yi executable uses a default+-- config.+yiDriver' :: Bool -> Config -> IO ()+yiDriver' ignoreUnknownArgs cfg = do+  args <- Dyre.withDyreOptions Dyre.defaultParams getArgs+  -- we do the arg processing before dyre, so we can extract+  -- '--ghc-option=' and '--help' and so on.+  case do_args ignoreUnknownArgs cfg args of+    Left (OptionError err code) -> T.putStrLn err >> exitWith code+    Right (finalCfg, cfgcon) -> do+      modules <- getCustomConfigPath (userConfigDir cfgcon) "modules"+      let yiParams = Dyre.defaultParams+                      { Dyre.projectName  = "yi"+                      , Dyre.realMain     = realMain+                      , Dyre.showError    = showErrorsInConf+                      , Dyre.configDir    = Just $ userConfigDir cfgcon+                      , Dyre.ghcOpts      = ["-threaded", "-O2", "-rtsopts"]+                                            ++ ["-i" ++ modules]+                                            ++ profilingParams+                                            ++ ghcOptions cfgcon+                      , Dyre.includeCurrentDirectory = False+                      , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I5"]+                      }+      Dyre.wrapMain yiParams (finalCfg, cfgcon)++-- | CPP-guarded profiling params.+profilingParams :: [String]+profilingParams =+#ifdef EVENTLOG+  ["-eventlog", "-rtsopts"] +++#endif+#ifdef PROFILING+  ["-prof", "-auto-all", "-rtsopts"+  , "-osuf=p_o", "-hisuf=p_hi"] +++#endif+  []
+ src/Yi/Boot/Internal.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Boot.Internal+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Internal use for Yi.Boot++module Yi.Boot.Internal where++import Config.Dyre.Relaunch (relaunchWithBinaryState)+import Control.Monad.Base   (liftBase)+import Control.Monad.State  (get)+import Yi.Keymap            (YiM, withUI)+import Yi.Types             (withEditor)+import Yi.UI.Common         (end)++-- | "reloads" the configuration+--+-- Serializes the editor state and relaunches Yi using the serialized+-- state. The launch of Yi will result in recompilation of the user's+-- custom Yi. This, in effect, "reloads" the configuration.+reload :: YiM ()+reload = do+  editor <- withEditor get+  withUI (`end` False)+  liftBase $ relaunchWithBinaryState (Just editor) Nothing
+ src/Yi/Buffer.hs view
@@ -0,0 +1,42 @@+{-# 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
+ src/Yi/Buffer/Adjusted.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Buffer.Adjusted+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This module re-exports Yi.Buffer overriding insert* and delete* functions+-- with their more indent-aware variants. It is intended to be imported+-- instead of Yi.Buffer or qualified to avoid name clashes.++module Yi.Buffer.Adjusted+    ( bdeleteB+    , insertB+    , insertN+    , insertNAt+    , deleteB+    , deleteN+    , deleteRegionB+    , deleteRegionWithStyleB+    , module Yi.Buffer+    ) where++import           Control.Monad       (forM_, when)+import           Yi.Buffer           hiding (bdeleteB, insertB, insertN, insertNAt+                                            , deleteB, deleteN, deleteNAt+                                            , deleteRegionB, deleteRegionWithStyleB)+import qualified Yi.Buffer           as B (deleteN, insertB, insertNAt)+import           Yi.Misc             (adjBlock)+import qualified Yi.Rope             as R (YiString, countNewLines, length, take)+import           Yi.Utils            (SemiNum ((~-)))++insertNAt :: R.YiString -> Point -> BufferM ()+insertNAt rope point | R.countNewLines rope > 0 = B.insertNAt rope point+insertNAt rope point = B.insertNAt rope point >> adjBlock (R.length rope)++-- | Insert the list at current point, extending size of buffer+insertN :: R.YiString -> BufferM ()+insertN rope = insertNAt rope =<< pointB++-- | Insert the char at current point, extending size of buffer+insertB :: Char -> BufferM ()+insertB c = B.insertB c >> adjBlock 1++-- | @deleteNAt n p@ deletes @n@ characters forwards from position @p@+deleteNAt :: Direction -> Int -> Point -> BufferM ()+deleteNAt dir n pos = do+  els <- R.take n <$> streamB Forward pos+  applyUpdate (Delete pos dir els)+  when (R.countNewLines els == 0) $+      adjBlock (-(R.length els))++deleteN :: Int -> BufferM ()+deleteN n = pointB >>= deleteNAt Forward n++deleteB :: TextUnit -> Direction -> BufferM ()+deleteB unit dir = deleteRegionB =<< regionOfPartNonEmptyB unit dir++bdeleteB :: BufferM ()+bdeleteB = deleteB Character Backward++deleteRegionB :: Region -> BufferM ()+deleteRegionB r =+    deleteNAt (regionDirection r)+              (fromIntegral (regionEnd r ~- regionStart r))+              (regionStart r)++deleteRegionWithStyleB :: Region -> RegionStyle -> BufferM Point+deleteRegionWithStyleB reg Block = savingPointB $ do+    (start, lengths) <- shapeOfBlockRegionB reg+    moveTo start+    forM_ (zip [1..] lengths) $ \(i, l) -> do+        B.deleteN l+        moveTo start+        lineMoveRel i+    return start++deleteRegionWithStyleB reg style = savingPointB $ do+    effectiveRegion <- convertRegionToStyleB reg style+    deleteRegionB effectiveRegion+    return $! regionStart effectiveRegion
+ src/Yi/Buffer/HighLevel.hs view
@@ -0,0 +1,1184 @@+{-# 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+    , 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.Maybe               (catMaybes, fromMaybe, listToMaybe)+import           Data.Monoid              ((<>))+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 occurence 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 occurence 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 occurence 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 occurence 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++-- ! 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+    MarkSet _ i _ <- markLines+    r <- winRegionB+    t <- lineOf (regionEnd r - 1)+    scrollB $ i - t++-- | 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 (\old w' -> ((w == w') || old 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+    movePoint <- use pointFollowsWindowA+    w <- askWindow wkey+    when (movePoint w) $ 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+    movePoint <- use pointFollowsWindowA+    w <- askWindow wkey+    if movePoint w 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 -> Maybe R.ConverterName -> UTCTime -> BufferM ()+revertB s cn now = do+  r <- regionOfB Document+  replaceRegionB r s+  encodingConverterNameA .= cn+  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+    moveTo start+    forM lengths $ \l -> do+        p0 <- pointB+        moveXorEol l+        p1 <- pointB+        let subRegion = mkRegion p0 p1+        moveTo p0+        void $ lineMoveRel 1+        return subRegion++deleteRegionWithStyleB :: Region -> RegionStyle -> BufferM Point+deleteRegionWithStyleB reg Block = savingPointB $ do+    (start, lengths) <- shapeOfBlockRegionB reg+    moveTo start+    forM_ (zip [1..] lengths) $ \(i, l) -> do+        deleteN l+        moveTo start+        lineMoveRel i+    return start++deleteRegionWithStyleB reg style = savingPointB $ do+    effectiveRegion <- convertRegionToStyleB reg style+    deleteRegionB effectiveRegion+    return $! 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 occurence 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
+ src/Yi/Buffer/Implementation.hs view
@@ -0,0 +1,452 @@+{-# 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+  , Overlay (..)+  , mkOverlay+  , overlayUpdate+  , applyUpdateI+  , isValidUpdate+  , reverseUpdateI+  , nelemsBI+  , 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+  , mem+  ) where++import           GHC.Generics        (Generic)++import           Data.Array          ((!))+import           Data.Binary         (Binary (..))+import           Data.Function       (on)+import           Data.List           (groupBy)+import qualified Data.Map            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'+            ]++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)}
+ src/Yi/Buffer/Indent.hs view
@@ -0,0 +1,376 @@+{-# 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.Normal    ()+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 preceds 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
+ src/Yi/Buffer/Misc.hs view
@@ -0,0 +1,1181 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes         #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# 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+  , modeAdjustBlockA+  , 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+  , encodingConverterNameA+  , stickyEolA+  ) where++import           Prelude                        hiding (foldr, mapM, notElem)++import           Lens.Micro.Platform                     (Lens', lens, (%~), (^.), use, (.=), (%=), view)+import           Control.Monad.RWS.Strict       (Endo (Endo, appEndo),+                                                 MonadReader (ask), MonadState,+                                                 MonadWriter (tell),+                                                 asks, gets, join, modify,+                                                 replicateM_, runRWS, void,+                                                 when, (<>))+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                       as M (Map, empty, insert, lookup)+import           Data.Maybe                     (fromMaybe, isNothing)+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           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)+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)+++uses l f = f <$> use l++-- 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 the number of characters specified.+--+-- >>> shortIdentString 3 (MemBuffer "hello")+-- "*hello*"+-- >>> shortIdentString 3 (FileBuffer "hello")+-- "lo"+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':+--+-- >>> identString (MemBuffer "hello")+-- "*hello*"+-- >>> identString (FileBuffer "hello")+-- "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+    enc <- use encodingConverterNameA >>= return . \case+      Nothing -> mempty :: T.Text+      Just cn -> T.pack $ R.unCn cn+    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 [ enc, " ", 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 = gets . queryRawbuf++modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM ()+modifyBuffer = modify . modifyRawbuf++queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x+queryAndModify = getsAndModify . queryAndModifyRawbuf++-- | Adds an "overlay" to the buffer+addOverlayB :: Overlay -> BufferM ()+addOverlayB ov = do+  pendingUpdatesA %= (++ [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 %= (++ [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, [Update], FBuffer)+runBufferFull w b f =+    let (a, b', updates) = runRWS (fromBufferM f') w b+        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 %~ (++ fmap TextUpdate updates) $ b')++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+  if transactionPresent+  then error "Already started update transaction"+  else 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 .= []++    undosA %= (appEndo . mconcat) (Endo . addChangeU . AtomicChange <$> transacAccum)+    undosA %= addChangeU InteractivePoint+++undoRedo :: (forall syntax. Mark -> URList -> BufferImpl syntax+             -> (BufferImpl syntax, (URList, [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'+      tell 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 (),+   modeAdjustBlock = \_ _ -> 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 = []+            , selectionStyle = SelectionStyle False False+            , keymapProcess = I.End+            , winMarks = M.empty+            , lastActiveWindow = dummyWindow unique+            , lastSyncTime = epoch+            , readOnly = False+            , directoryContent = False+            , inserting = True+            , pointFollowsWindow = const False+            , updateTransactionInFlight = False+            , updateTransactionAccum = []+            , fontsizeVariation = 0+            , encodingConverterName = Nothing+            } }++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+  ro    <- checkRO+  valid <- queryBuffer (isValidUpdate update)+  when (not ro && valid) $ do+    forgetPreferCol+    let reversed = reverseUpdateI update+    modifyBuffer (applyUpdateI update)++    isTransacPresent <- use updateTransactionInFlightA+    if isTransacPresent+    then updateTransactionAccumA %= (reversed:)+    else undosA %= addChangeU (AtomicChange reversed)++    tell [update]+   -- otherwise, just ignore.++-- | Revert all the pending updates; don't touch the point.+revertPendingUpdatesB :: BufferM ()+revertPendingUpdatesB = do+  updates <- use pendingUpdatesA+  modifyBuffer (flip (foldr (\u bi -> applyUpdateI (reverseUpdateI u) bi)) [u | TextUpdate u <- 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 = join . gets . withMode0++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' = join . withSyntaxB++-- | 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 = preferColA .= Nothing >> preferVisColA .= Nothing++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 :: Mark -> Lens' FBuffer Point+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
+ src/Yi/Buffer/Normal.hs view
@@ -0,0 +1,103 @@+{-# 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
+ src/Yi/Buffer/Region.hs view
@@ -0,0 +1,145 @@+{-# 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+        end = regionEnd 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
+ src/Yi/Buffer/TextUnit.hs view
@@ -0,0 +1,440 @@+{-# 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
+ src/Yi/Buffer/Undo.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE TemplateHaskell    #-}++-- | 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 orginally 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 partialy+-- >    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+  , setSavedFilePointU+  , isAtSavedFilePointU+  , undoU+  , redoU+  , URList             {- abstractly -}+  , Change(AtomicChange, InteractivePoint)+   ) where++import           GHC.Generics             (Generic)++import           Data.Binary              (Binary (..))+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 ![Change] ![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 [SavedFilePoint] []++-- | 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 _rs) = URList (u:us) []++-- | 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 : cleanUndos) cleanRedos+  where+  cleanUndos = filter isNotSavedFilePoint undos+  cleanRedos = filter isNotSavedFilePoint redos+  isNotSavedFilePoint :: Change -> Bool+  isNotSavedFilePoint SavedFilePoint = False+  isNotSavedFilePoint _              = True++-- | This undoes one interaction step.+undoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoU m = undoUntilInteractive m [] . undoInteractive++-- | This redoes one iteraction step.+redoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [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)++remIP, addIP :: [Change] -> [Change]++-- | Remove an initial interactive point, if there is one+remIP (InteractivePoint:xs) = xs+remIP xs = xs++-- | Insert an initial interactive point, if there is none+addIP xs@(InteractivePoint:_) = xs+addIP xs = InteractivePoint:xs++-- | Repeatedly undo actions, storing away the inverse operations in the+--   redo list.+undoUntilInteractive :: Mark -> [Update] -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoUntilInteractive pointMark xs ur@(URList cs rs) b = case cs of+      []                   -> (b, (ur, xs))+      [SavedFilePoint]     -> (b, (ur, xs)) -- Why this special case?+      (InteractivePoint:_) -> (b, (ur, xs))+      (SavedFilePoint:cs') ->+        undoUntilInteractive pointMark xs (URList cs' (SavedFilePoint:rs)) b+      (AtomicChange u:cs') ->+        let ur' = URList cs' (AtomicChange (reverseUpdateI u):rs)+            b' = applyUpdateWithMoveI u b+            (b'', (ur'', xs'')) = undoUntilInteractive pointMark xs ur' b'+        in (b'', (ur'', u:xs''))+    where+      -- Apply a /valid/ update and also move point in buffer to update position+      applyUpdateWithMoveI :: Update -> BufferImpl syntax -> BufferImpl syntax+      applyUpdateWithMoveI u = case updateDirection u 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, [Update]))) -> URList -> t -> (t, (URList, [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 cs of+      []                       -> False+      (SavedFilePoint : _)     -> True+      (InteractivePoint : cs') -> isUnchanged cs'+      _                        -> False
+ src/Yi/Command.hs view
@@ -0,0 +1,146 @@+{-# 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.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 (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 ouput 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 ()++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) = buildRun "cabal" (cmd:args) onExit++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) = buildRun "stack" (cmd:args) onExit
+ src/Yi/Command/Help.hs view
@@ -0,0 +1,58 @@+{-# 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
+ src/Yi/Completion.hs view
@@ -0,0 +1,141 @@+{-# 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+  , containsMatch', containsMatch, containsMatchCaseInsensitive+  , isCasePrefixOf+  )+where++import           Data.Function       (on)+import           Data.List           (find, nub)+import           Data.Maybe          (catMaybes)+import           Data.Monoid         ((<>))+import qualified Data.Text           as T (Text, breakOn, isPrefixOf, length, null, tails, toCaseFold)+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 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++-- | 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
+ src/Yi/CompletionTree.hs view
@@ -0,0 +1,194 @@+{-# 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)++-- | 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 (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 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' (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)) ++ "]"
+ src/Yi/Config.hs view
@@ -0,0 +1,31 @@+{-# 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
+ src/Yi/Config/Default.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Yi.Config.Default (defaultConfig) where+++import           Lens.Micro.Platform          ((.~), (^.), use)+import           Control.Monad+import qualified Data.HashMap.Strict as HM+import qualified Data.Map            as M+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.Config.Misc+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+           }+         , defaultKm        = modelessKeymapSet nilKeymap+         , startActions     = []+         , initialActions   = []+         , modeTable = [AnyMode fundamentalMode]+         , debugMode = False+         , configKillringAccumulate = False+         , configCheckExternalChangesObsessively = True+         , configRegionStyle = Exclusive+         , configInputPreprocess = I.idAutomaton+         , bufferUpdateHandler = []+         , 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
+ src/Yi/Config/Lens.hs view
@@ -0,0 +1,26 @@+{-# 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
+ src/Yi/Config/Misc.hs view
@@ -0,0 +1,3 @@+module Yi.Config.Misc where++data ScrollStyle = SnapToCenter | SingleLine
+ src/Yi/Config/Simple.hs view
@@ -0,0 +1,377 @@+{-# 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 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,+  configMain,+  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,+  -- ** 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.Boot,+  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           Control.Monad.State hiding (modify, get)+import           Data.Maybe(mapMaybe)+import qualified Data.Text as T+import           Text.Printf(printf)+import           Yi.Boot+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,+                           )+++--------------- Main interface+-- newtype ConfigM a   (imported)++-- | Starts with the given initial config, makes the described+-- modifications, then starts yi.+configMain :: Config -> ConfigM () -> IO ()+configMain c m = yi =<< execStateT (runConfigM m) c++------------------------- 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++---------- 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+functinality, 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 [[Update] -> BufferM ()]+bufferUpdateHandler = bufferUpdateHandlerA
+ src/Yi/Config/Simple/Types.hs view
@@ -0,0 +1,38 @@+{-# 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
+ src/Yi/Core.hs view
@@ -0,0 +1,559 @@+{-# 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 ()++  -- * 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+  , forkAction+  ) where++import           Prelude                        hiding (elem, mapM_, or)++import           Control.Concurrent             (ThreadId, forkIO, 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), (<>))+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)+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)+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)+++uses l f = f <$> use l+-- | 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++-- | 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)++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 if it is not already visible.+showErrors :: YiM ()+showErrors = withEditor $ do+               bs <- gets $ findBufferWithName "*errors*"+               case bs of+                 [] -> return ()+                 _  -> 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 = do+    savePersistentState+    onYiVar $ terminateSubprocesses (const True)+    withUI (`UI.end` True)++-- | 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, c) ->+                              (runDummy b (revertB newContents (Just c) 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 .~ []+    clearFollow = pointFollowsWindowA .~ const False+    -- 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: varients 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
+ src/Yi/Debug.hs view
@@ -0,0 +1,100 @@+{-# 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 ()
+ src/Yi/Dired.hs view
@@ -0,0 +1,1118 @@+{-# 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+<https://www.gnu.org/software/emacs/manual/html_node/emacs/Dired.html dired>+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.Reader     (asks, foldM, unless, void, when)+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)+import           System.PosixCompat.User  (GroupEntry, GroupEntry (..),+                                           UserEntry (..), getAllGroupEntries,+                                           getAllUserEntries,+                                           getGroupEntryForID,+                                           getUserEntryForID, groupID, userID)+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, conv) -> do+        permissions <- io $ getPermissions f++        b <- stringToNewBuffer (FileBuffer f) contents+        withGivenBuffer b $ do+          encodingConverterNameA .= Just conv+          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+-- directry, but only the top level one+--+-- 3. Show the number of successful deletions at the end of the excution+--+-- 4. TODO: ask confirmation for wether 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+    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+++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 excute 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
+ src/Yi/Editor.hs view
@@ -0,0 +1,818 @@+{-# 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+                 , 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, (%=), (%~),+                                                 (&), (.~), (^.), (.=),+                                                 ASetter)+import           Control.Monad                  (forM_, liftM)+import           Control.Monad.Reader           (MonadReader (ask), asks,+                                                 unless, when)+import           Control.Monad.State            (gets, modify, MonadState)+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, 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.Text                      as T (Text, null, pack, unlines, unpack, unwords)+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                       (getsAndModify)+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++assign :: MonadState s m => ASetter s s a b -> b -> m ()+assign = (.=)++uses l f = f <$> use l ++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+      sameIdent b = shortIdentString (length $ commonNamePrefix e) b == n+  in map bkey $ filter sameIdent bufs++-- | 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++------------------------------------------------------------------------+-- | 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 %~+                        if accum && all updateIsDelete us+                        then foldl (.) id $ reverse [ krPut dir s+                                                    | Delete _ dir s <- us ]+                        else id++                  , (us, v))+  (us, v) <- getsAndModify edit++  updHandler <- return . bufferUpdateHandler =<< ask+  unless (null us || 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 restult 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) =+          case findBufferWithName currentName e of+            (_b : _) -> find_next nextName otherNames+            []      -> 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)
+ src/Yi/Eval.hs view
@@ -0,0 +1,401 @@+{-# 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, void, forever)+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.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,+      interpret )+import System.Directory ( doesFileExist )+import Yi.Boot.Internal ( reload )+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?++-- | 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++-- | 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)++-- | The evaluator to use for 'execEditorAction' and+-- 'getAllNamesInScope'.+evaluator :: Field Evaluator+evaluator = customVariable++-- * 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 dictioary 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+type HintRequest = (String, MVar (Either LHI.InterpreterError Action))+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+    LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")]+    forever $ do+      (s,response) <- lift $ takeMVar request+      res <- try $ LHI.interpret ("Yi.makeAction (" ++ s ++ ")") (LHI.as :: Action)+      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 "reload" = reload+    execAction s = do+      request <- getHintThread+      res <- io $ do+        response <- newEmptyMVar+        putMVar request (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+                  res <- io $ LHI.runInterpreter $ do+                    LHI.set [LHI.searchPath LHI.:= []]+                    LHI.getModuleExports "Yi"+                  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+                         result <- io $ LHI.runInterpreter $ do+                           LHI.set [LHI.searchPath LHI.:= []]+                           -- when haveUserContext $ do+                           --   LHI.loadModules [contextFile]+                           --   LHI.setTopLevelModules ["Env"]+                           LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")]+                           LHI.typeOf name+                         let newDescription = either show id result+                         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, 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
+ src/Yi/Event.hs view
@@ -0,0 +1,69 @@+module 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+++
+ src/Yi/File.hs view
@@ -0,0 +1,199 @@+{-# 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, writeFileUsingText)+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, cv) -> return $ Just (c, Just cv)+      case rf of+       Nothing -> return ()+       Just (s, conv) -> do+         withCurrentBuffer $ revertB s conv 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+    conv <- use encodingConverterNameA+    return (fl, st, conv)++  case nameContents of+    (Just f, contents, conv) -> 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 $ case conv of+          Nothing -> R.writeFileUsingText f contents >> return Nothing+          Just cn -> R.writeFile f contents cn+        case mayErr of+          Just err -> printMsg err >> return False+          Nothing -> 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)
+ src/Yi/History.hs view
@@ -0,0 +1,151 @@+{-# 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
+ src/Yi/Hoogle.hs view
@@ -0,0 +1,98 @@+{-# 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
+ src/Yi/Hooks.hs view
@@ -0,0 +1,102 @@+{- | 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)
+ src/Yi/IncrementalParse.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ScopedTypeVariables #-}++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
+ src/Yi/Interact.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# 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           Control.Monad.State (MonadPlus (..), MonadTrans (lift), StateT)+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+  fail _  = Fails+  (>>=)   = Binds++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 _) = [["<any>"]]+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)++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) => [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) => [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)
+ src/Yi/JumpList.hs view
@@ -0,0 +1,46 @@+{-# 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) = "<Jump " ++ show mark ++ " " ++ show 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
+ src/Yi/Keymap.hs view
@@ -0,0 +1,143 @@+{-# 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
+ src/Yi/Keymap/Keys.hs view
@@ -0,0 +1,123 @@+{-# 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 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 :: (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 :: (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 ::(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 ?*>>
+ src/Yi/KillRing.hs view
@@ -0,0 +1,89 @@+{-# 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
+ src/Yi/Layout.hs view
@@ -0,0 +1,397 @@+{-# 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
+ src/Yi/Main.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This is the main module of Yi, called with configuration from the user.+-- Here we mainly process command line arguments.++module Yi.Main (+                -- * Static main+                main,+                -- * Command line processing+                do_args,+                ConsoleConfig(..),+               ) where++import Control.Monad+import Data.Char+import Data.Monoid+import qualified Data.Text as T+import Data.List (intercalate)+import Data.Version (showVersion)+import Lens.Micro.Platform (view)+import System.Console.GetOpt+import System.Exit+#ifndef HLINT+#include "ghcconfig.h"+#endif++import Yi.Buffer+import Yi.Config+import Yi.Core (startEditor)+import Yi.Debug+import Yi.Editor+import Yi.File+import Yi.Keymap+import Yi.Option (YiOption, OptionError(..), yiCustomOptions)+import Yi.Paths (getConfigDir)+import Paths_yi_core++-- | Configuration information which can be set in the command-line, but not+-- in the user's configuration file.+data ConsoleConfig =+  ConsoleConfig {+     ghcOptions :: [String],+     selfCheck :: Bool,+     userConfigDir :: IO FilePath+  }++defaultConsoleConfig :: ConsoleConfig+defaultConsoleConfig =+  ConsoleConfig {+                  ghcOptions = [],+                  selfCheck = False,+                  userConfigDir = Yi.Paths.getConfigDir+                }++-- ---------------------------------------------------------------------+-- | Argument parsing. Pretty standard.++data Opts = Help+          | Version+          | LineNo String+          | EditorNm String+          | File String+          | Frontend String+          | ConfigFile String+          | SelfCheck+          | GhcOption String+          | Debug+          | OpenInTabs+          | CustomNoArg YiOption+          | CustomReqArg (String -> YiOption) String+          | CustomOptArg (Maybe String -> YiOption) (Maybe String)++-- | List of editors for which we provide an emulation.+editors :: [(String,Config -> Config)]+editors = []++builtinOptions :: [OptDescr Opts]+builtinOptions =+  [ Option []     ["self-check"]  (NoArg  SelfCheck)             "Run self-checks"+  , Option ['f']  ["frontend"]    (ReqArg Frontend   "FRONTEND") frontendHelp+  , Option ['y']  ["config-file"] (ReqArg ConfigFile "PATH")     "Specify a folder containing a configuration yi.hs file"+  , Option ['V']  ["version"]     (NoArg  Version)               "Show version information"+  , Option ['h']  ["help"]        (NoArg  Help)                  "Show this help"+  , Option []     ["debug"]       (NoArg  Debug)                 "Write debug information in a log file"+  , Option ['l']  ["line"]        (ReqArg LineNo     "NUM")      "Start on line number"+  , Option []     ["as"]          (ReqArg EditorNm   "EDITOR")   editorHelp+  , Option []     ["ghc-option"]  (ReqArg GhcOption  "OPTION")   "Specify option to pass to ghc when compiling configuration file"+  , Option [openInTabsShort] [openInTabsLong] (NoArg  OpenInTabs)  "Open files in tabs"+  ] where frontendHelp = "Select frontend"+          editorHelp   = "Start with editor keymap, where editor is one of:\n" ++ (intercalate ", " . fmap fst) editors++convertCustomOption :: OptDescr YiOption -> OptDescr Opts+convertCustomOption (Option short long desc help) = Option short long desc' help+    where desc' = convertCustomArgDesc desc++convertCustomArgDesc :: ArgDescr YiOption -> ArgDescr Opts+convertCustomArgDesc (NoArg o) = NoArg (CustomNoArg o)+convertCustomArgDesc (ReqArg f s) = ReqArg (CustomReqArg f) s+convertCustomArgDesc (OptArg f s) = OptArg (CustomOptArg f) s++customOptions :: Config -> [OptDescr Opts]+customOptions = fmap convertCustomOption . view yiCustomOptions++openInTabsShort :: Char+openInTabsShort = 'p'++openInTabsLong :: String+openInTabsLong = "open-in-tabs"++-- | usage string.+usage :: [OptDescr Opts] -> T.Text+usage opts = T.pack $ usageInfo "Usage: yi [option...] [file]" opts++versinfo :: T.Text+versinfo = "yi " <> T.pack (showVersion version)++-- | Transform the config with options+do_args :: Bool -> Config -> [String] -> Either OptionError (Config, ConsoleConfig)+do_args ignoreUnknown cfg args = let options = customOptions cfg ++ builtinOptions in+    case getOpt' (ReturnInOrder File) options args of+        (os, [], [], []) -> handle options os+        (os, _, u:us, []) -> if ignoreUnknown+                                    then handle options os+                                    else fail $ "unknown arguments: " ++ intercalate ", " (u:us)+        (os, ex, ey, errs) -> fail (concat errs)+    where+        shouldOpenInTabs = ("--" ++ openInTabsLong) `elem` args+                         || ('-':[openInTabsShort]) `elem` args+        handle options os = foldM (getConfig options shouldOpenInTabs) (cfg, defaultConsoleConfig) (reverse os)++-- | Update the default configuration based on a command-line option.+getConfig :: [OptDescr Opts] -> Bool -> (Config, ConsoleConfig) -> Opts -> Either OptionError (Config, ConsoleConfig)+getConfig options shouldOpenInTabs (cfg, cfgcon) opt =+    case opt of+      Frontend _    -> fail "Panic: frontend not found"+      Help          -> Left $ OptionError (usage options) ExitSuccess+      Version       -> Left $ OptionError versinfo ExitSuccess+      Debug         -> return (cfg { debugMode = True }, cfgcon)+      LineNo l      -> case startActions cfg of+                         x : xs -> return (cfg { startActions = x:makeAction (gotoLn (read l)):xs }, cfgcon)+                         []     -> fail "The `-l' option must come after a file argument"++      File filename -> if shouldOpenInTabs && not (null (startActions cfg)) then+                         prependActions [YiA $ openNewFile filename, EditorA newTabE]+                       else+                         prependAction $ openNewFile filename++      EditorNm emul -> case lookup (fmap toLower emul) editors of+             Just modifyCfg -> return (modifyCfg cfg, cfgcon)+             Nothing -> fail $ "Unknown emulation: " ++ show emul+      GhcOption ghcOpt -> return (cfg, cfgcon { ghcOptions = ghcOptions cfgcon ++ [ghcOpt] })+      ConfigFile f -> return (cfg, cfgcon { userConfigDir = return f })+      CustomNoArg o -> do+          cfg' <- o cfg+          return (cfg', cfgcon)+      CustomReqArg f s -> do+          cfg' <- f s cfg+          return (cfg', cfgcon)+      CustomOptArg f s -> do+          cfg' <- f s cfg+          return (cfg', cfgcon)+      _ -> return (cfg, cfgcon)+  where+    prependActions as = return (cfg { startActions = fmap makeAction as ++ startActions cfg }, cfgcon)+    prependAction a = return (cfg { startActions = makeAction a : startActions cfg}, cfgcon)++-- ---------------------------------------------------------------------+-- | Static main. This is the front end to the statically linked+-- application, and the real front end, in a sense. 'dynamic_main' calls+-- this after setting preferences passed from the boot loader.+--+main :: (Config, ConsoleConfig) -> Maybe Editor -> IO ()+main (cfg, _cfgcon) state = do+  when (debugMode cfg) $ initDebug ".yi.dbg"+  startEditor cfg state
+ src/Yi/MiniBuffer.hs view
@@ -0,0 +1,438 @@+{-# 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 #-}++-- |+-- 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, debugBufferContent+                     ) where++import           Control.Concurrent             (threadDelay)+import           Lens.Micro.Platform                   (use, (%=))+import           Control.Monad                  (forM, void, when, (<=<), (>=>))+import           Data.Foldable                  (find, toList)+import           Data.IORef                     (newIORef, readIORef, writeIORef)+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                        (forkAction, 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.Utils                       (io)+import           Yi.Window                      (bufkey)++-- | 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))++-- | 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 occurence 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 broguht 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"
+ src/Yi/Misc.hs view
@@ -0,0 +1,214 @@+{-# 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, adjBlock, adjIndent+               , promptFile , promptFileChangingHints, matchFile, completeFile+               , printFileInfoE, debugBufferContent+               ) where++import           Control.Monad           (filterM, (>=>))+import           Control.Monad.Base      (liftBase)+import           Data.Char               (chr, isAlpha, isLower, isUpper, ord)+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.Editor               (EditorM, printMsg, withCurrentBuffer)+import           Yi.Keymap               (YiM)+import           Yi.MiniBuffer           (debugBufferContent, mkCompleteFn, withMinibufferGen)+import           Yi.Monad                (gets)+import qualified Yi.Rope                 as R (fromText)+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<Tab>"+  --+  -- @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<Tab>", 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++adjBlock :: Int -> BufferM ()+adjBlock x = withSyntaxB' (\m s -> modeAdjustBlock m s x)++-- | 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+            , "]"+            ]
+ src/Yi/Mode/Common.hs view
@@ -0,0 +1,168 @@+{-# 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, isJust)+import           System.FilePath      (takeExtension)+import qualified Data.Text            as T (Text)++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)
+ src/Yi/Mode/Compilation.hs view
@@ -0,0 +1,40 @@+{-# 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 ()
+ src/Yi/Mode/Interactive.hs view
@@ -0,0 +1,135 @@+{-# 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, recieve 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
+ src/Yi/Monad.hs view
@@ -0,0 +1,41 @@+module Yi.Monad (+                 gets,+                 getsAndModify,+                 maybeM,+                 repeatUntilM,+                 whenM,+                 with,+                ) where++import Control.Monad.Base   (MonadBase, liftBase)+import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.State  (MonadState, get, gets, put, when)++-- | 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]
+ src/Yi/Option.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Option+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Command-line options++module Yi.Option+    (+    -- * Types+      YiOption+    , YiOptionDescr+    , YiOptions+    , OptionError(..)++    -- * Core+    , yiCustomOptions+    , consYiOption+    , consYiOptions++    -- * Argument-less options+    , yiBoolOption+    , yiFlagOption+    , yiActionFlagOption++    -- * Argument-taking options+    , yiStringOption+    , yiStringOption'+    , yiActionOption+    , yiActionOption'+    )+where++import           Data.Default          (Default)+import qualified Data.Text             as T (Text)+import           Data.Typeable         (Typeable)+import           Data.String           (IsString, fromString)+import           Lens.Micro.Platform   (Lens', makeLenses, over, set)+import           System.Exit           (ExitCode)+import           System.Console.GetOpt (OptDescr, ArgDescr(..))+import           Yi.Config.Lens        (configVariable, startActionsA)+import           Yi.Types              (Action, Config, YiConfigVariable)++data OptionError = OptionError T.Text ExitCode++-- | An option is a function that attempts to change the configuration of the+-- editor at runtime.+type YiOption = Config -> Either OptionError Config++type YiOptionDescr = OptDescr YiOption++-- | Custom options that should be accepted. Provided in user configuration.+--+-- The general flow is that the user adds options to his configuration. Options+-- are essentially functions describing how to modify the configuration at runtime.+-- When an option is called, it gets the current config and may modify it (to encode+-- its value)+newtype YiOptions = YiOptions { _yiOptions :: [YiOptionDescr] }+    deriving (Default, Typeable)++instance YiConfigVariable YiOptions++makeLenses ''YiOptions++-- | Lens for accessing the list of custom options.+--+-- You can pretty much create whatever types of options you want with this.+-- But most cases are taken care of by one of the helper functions in this module.+yiCustomOptions :: Lens' Config [YiOptionDescr]+yiCustomOptions = configVariable . yiOptions++-- | Includes an extra option in the configuration. Small wrapper around 'yiCustomOptions'+consYiOption :: YiOptionDescr -> Config -> Config+consYiOption opt = over yiCustomOptions (opt:)++-- | Like 'consYiOption' but supports multiple options. Convenient for keymaps which might+-- want to install lots of options.+consYiOptions :: [YiOptionDescr] -> Config -> Config+consYiOptions opts = over yiCustomOptions (opts++)++-- | An argument which sets some configuration value to 'True'.+yiBoolOption :: Lens' Config Bool -> ArgDescr YiOption+yiBoolOption lens = NoArg $ Right . set lens True++-- | An argument which applies a function transforming some inner value of+-- the configuration.+yiFlagOption :: Lens' Config a -> (a -> a) -> ArgDescr YiOption+yiFlagOption lens f = NoArg $ Right . over lens f++-- | Flag that appends an action to the startup actions.+yiActionFlagOption :: Action -> ArgDescr YiOption+yiActionFlagOption action = NoArg f+    where f config = Right $ over startActionsA (++[action]) config+ +-- | Sets the value of an option which is any string type (hopefully text...)+--+-- This is not meant to be fully applied. By only passing in the lens you+-- will obtain a value suitable for use in OptDescr.+yiStringOption :: IsString a => Lens' Config a -> String -> ArgDescr YiOption+yiStringOption lens desc = ReqArg f desc+    where f string config = Right $ set lens (fromString string) config++-- | Just like 'yiStringOption', except it applies a 'Just'. Useful for setting+-- string-like values whose default is 'None'.+yiStringOption' :: IsString a => Lens' Config (Maybe a) -> String -> ArgDescr YiOption+yiStringOption' lens desc = ReqArg f desc+    where f string config = Right $ set lens (Just $ fromString string) config++-- | Option that appends a parameterized action to the startup actions.+yiActionOption :: IsString a => (a -> Action) -> String -> ArgDescr YiOption+yiActionOption action desc = ReqArg f desc+    where f string config = Right $ over startActionsA (++[action (fromString string)]) config++yiActionOption' :: IsString a => (a -> Either OptionError Action) -> String -> ArgDescr YiOption+yiActionOption' action desc = ReqArg f desc+    where f string config = do+            action' <- action (fromString string)+            return $ over startActionsA (++[action']) config
+ src/Yi/Paths.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Yi.Paths ( getEvaluatorContextFilename+                , getConfigFilename+                , getConfigModules+                , getArticleDbFilename+                , 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,+    getArticleDbFilename, getPersistentStateFilename :: (MonadBase IO m) => m FilePath++-- | Get Yi master configuration script.+getConfigFilename = getConfigPath "yi.hs"++getConfigModules = getConfigPath "modules"++-- | Get articles.db database of locations to visit (for Yi.IReader.)+getArticleDbFilename = getConfigPath "articles.db"++-- | 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"
+ src/Yi/PersistentState.hs view
@@ -0,0 +1,127 @@+{-# 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
+ src/Yi/Process.hs view
@@ -0,0 +1,107 @@+{-# 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)++#ifndef mingw32_HOST_OS+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 simplifiy 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)
+ src/Yi/Rectangle.hs view
@@ -0,0 +1,107 @@+{-# 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 qualified Data.Text.ICU       as ICU (regex, find, unfold, group)+import           Yi.Buffer+import           Yi.Editor           (EditorM, getRegE, setRegE, withCurrentBuffer)+import qualified Yi.Rope             as R+import           Yi.String           (lines', mapLines, unlines')++alignRegion :: T.Text -> BufferM ()+alignRegion str = do+  s <- getSelectRegionB >>= unitWiseRegion Line+  modifyRegionB (R.fromText . alignText str . R.toText) s+  where+    regexSplit :: T.Text -> T.Text -> [T.Text]+    regexSplit pattern l = case ICU.find (ICU.regex [] pattern) l of+        Nothing -> error "regexSplit: text does not match"+        Just m  -> drop 1 $ ICU.unfold ICU.group m++    alignText :: T.Text -> T.Text -> T.Text+    alignText regex text = unlines' ls'+      where ls, ls' :: [T.Text]+            ls = lines' text+            columns :: [[T.Text]]+            columns = regexSplit regex <$> ls++            columnsWidth :: [Int]+            columnsWidth = fmap (maximum . fmap T.length) $ transpose columns++            columns' :: [[T.Text]]+            columns' = fmap (zipWith (`T.justifyLeft` ' ') columnsWidth) columns++            ls' = T.concat <$> columns'++-- | Align each line of the region on the given regex.+-- Fails if it is not found in any line.+alignRegionOn :: T.Text -> BufferM ()+alignRegionOn s = alignRegion $ "^(.*)(" <> s <> ")(.*)"++-- | 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
+ src/Yi/Search.hs view
@@ -0,0 +1,441 @@+{-# 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+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++-- | Succesfully 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 occurence 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
+ src/Yi/Search/Internal.hs view
@@ -0,0 +1,36 @@+{-# 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
+ src/Yi/Snippets.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Snippets+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable++module Yi.Snippets where++import           GHC.Generics (Generic)++import           Control.Applicative (some)+import           Control.Arrow       (second)+import           Lens.Micro.Platform          (use, (.=))+import           Control.Monad.RWS   (MonadPlus (mplus), MonadReader (ask),+                                      MonadState, MonadTrans (..),+                                      MonadWriter (tell), RWST, evalRWST,+                                      filterM, forM, forM_, liftM2, unless,+                                      when, (<>))+import           Data.Binary         (Binary)+import           Data.Char           (isSpace)+import           Data.Default        (Default, def)+import           Data.Foldable       (find)+import           Data.List           (foldl', groupBy, intersperse, nub, sort)+import           Data.Maybe          (catMaybes)+import qualified Data.Text           as T (Text)+import           Data.Typeable       (Typeable)+import           Yi.Buffer+import           Yi.Editor           (withCurrentBuffer)+import           Yi.Keymap           (Action)+import           Yi.Keymap.Keys+import qualified Yi.Rope             as R+import           Yi.TextCompletion   (resetComplete, wordCompleteString')+import           Yi.Types            (YiVariable)++type SnippetCmd = RWST (Int, Int) [MarkInfo] () BufferM++data SnippetMark = SimpleMark !Int+                 | ValuedMark !Int R.YiString+                 | DependentMark !Int+++data MarkInfo = SimpleMarkInfo { userIndex :: !Int+                               , startMark :: !Mark }+              | ValuedMarkInfo { userIndex :: !Int+                               , startMark :: !Mark+                               , endMark :: !Mark }+              | DependentMarkInfo { userIndex :: !Int+                                  , startMark :: !Mark+                                  , endMark :: !Mark }+  deriving (Eq, Show, Generic)++instance Binary MarkInfo++newtype BufferMarks = BufferMarks { bufferMarks :: [MarkInfo] }+  deriving (Eq, Show, Monoid, Typeable, Binary)++newtype DependentMarks = DependentMarks { marks :: [[MarkInfo]] }+  deriving (Eq, Show, Monoid, Typeable, Binary)++instance Default BufferMarks where+  def = BufferMarks []++instance Default DependentMarks where+  def = DependentMarks []++instance YiVariable BufferMarks+instance YiVariable DependentMarks++instance Ord MarkInfo where+  a `compare` b = userIndex a `compare` userIndex b++cursor :: Int -> SnippetMark+cursor = SimpleMark++cursorWith :: Int -> R.YiString -> SnippetMark+cursorWith = ValuedMark++dep :: Int -> SnippetMark+dep = DependentMark++isDependentMark :: MarkInfo -> Bool+isDependentMark (SimpleMarkInfo{})    = False+isDependentMark (ValuedMarkInfo{})    = False+isDependentMark (DependentMarkInfo{}) = True++bufferMarkers :: MarkInfo -> [Mark]+bufferMarkers (SimpleMarkInfo _ s) = [s]+bufferMarkers m = [startMark m, endMark m]++-- used to translate a datatype into a snippet cmd for+-- freely combining data with '&'+class MkSnippetCmd a b | a -> b where+  mkSnippetCmd :: a -> SnippetCmd b++instance MkSnippetCmd String () where+  mkSnippetCmd = text . R.fromString++instance MkSnippetCmd R.YiString () where+  mkSnippetCmd = text++instance MkSnippetCmd T.Text () where+  mkSnippetCmd = text . R.fromText++instance MkSnippetCmd (SnippetCmd a) a where+  mkSnippetCmd = id++-- mkSnippetCmd for 'cursor...'-functions+instance MkSnippetCmd SnippetMark () where+  mkSnippetCmd (SimpleMark i) = do+      mk <- mkMark+      tell [SimpleMarkInfo i mk]++  mkSnippetCmd (ValuedMark i str) = do+      start <- mkMark+      lift $ insertN str+      end <- mkMark+      tell [ValuedMarkInfo i start end]++  mkSnippetCmd (DependentMark i) = do+      start <- mkMark+      end <- mkMark+      tell [DependentMarkInfo i start end]++-- create a mark at current position+mkMark :: MonadTrans t => t BufferM Mark+mkMark = lift $ do p <- pointB+                   newMarkB $ MarkValue p Backward++-- Indentation support has been temporarily removed+text :: R.YiString -> SnippetCmd ()+text txt = do+  (_, indent) <- ask+  indentSettings <- lift indentSettingsB+  lift . foldl' (>>) (return ()) .+      intersperse (newlineB >> indentToB indent) .+      map (if expandTabs indentSettings+           then insertN . expand indentSettings ""+           else insertN) $ lines' txt+  where+    lines' txt' = case R.last txt' of+      Just '\n' -> R.lines txt' <> [mempty]+      _         -> R.lines txt++    expand :: IndentSettings -> R.YiString -> R.YiString -> R.YiString+    expand is str rst = case R.head rst of+      Nothing -> R.reverse str+      Just '\t' -> let t = R.replicateChar (tabSize is) ' ' <> str+                   in expand is t (R.drop 1 rst)+      Just s -> expand is (s `R.cons` str) rst++-- unfortunatelly data converted to snippets are no monads, but '&' is+-- very similar to '>>' and '&>' is similar to '>>=', since+-- SnippetCmd's can be used monadically+infixr 5 &+(&) :: (MkSnippetCmd a any , MkSnippetCmd b c) => a -> b -> SnippetCmd c+str & rst = mkSnippetCmd str >> mkSnippetCmd rst++(&>) :: (MkSnippetCmd a b, MkSnippetCmd c d) => a -> (b -> c) -> SnippetCmd d+str &> rst = mkSnippetCmd str >>= mkSnippetCmd . rst++runSnippet :: Bool -> SnippetCmd a -> BufferM a+runSnippet deleteLast s = do+    line <- lineOf =<< pointB+    indent <- indentOfCurrentPosB+    (a, markInfo) <- evalRWST s (line, indent) ()+    unless (null markInfo) $ do+        let newMarks = sort $ filter (not . isDependentMark) markInfo+        let newDepMarks = filter (not . len1) $+                            groupBy belongTogether $+                              sort markInfo+        getBufferDyn >>= putBufferDyn.(BufferMarks newMarks `mappend`)+        unless (null newDepMarks) $+            getBufferDyn >>= putBufferDyn.(DependentMarks newDepMarks `mappend`)+        moveToNextBufferMark deleteLast+    return a+  where+    len1 (_:[]) = True+    len1 _      = False++    belongTogether a b = userIndex a == userIndex b++updateUpdatedMarks :: [Update] -> BufferM ()+updateUpdatedMarks upds = findEditedMarks upds >>=+                          mapM_ updateDependents++findEditedMarks :: [Update] -> BufferM [MarkInfo]+findEditedMarks upds = fmap (nub . concat) (mapM findEditedMarks' upds)+  where+    findEditedMarks' :: Update -> BufferM [MarkInfo]+    findEditedMarks' upd = do+        let p = updatePoint upd+        ms <- return . nub . concat . marks =<< getBufferDyn+        ms' <- forM ms $ \m ->do+                 r <- adjMarkRegion m+                 return $ if (updateIsDelete upd && p `nearRegion` r)+                             || p `inRegion` r+                          then Just m+                          else Nothing+        return . catMaybes $ ms'++dependentSiblings :: MarkInfo -> [[MarkInfo]] -> [MarkInfo]+dependentSiblings mark deps =+  case find (elem mark) deps of+    Nothing -> []+    Just lst -> filter (not . (mark==)) lst++updateDependents :: MarkInfo -> BufferM ()+updateDependents m = getBufferDyn >>= updateDependents' m . marks++updateDependents' :: MarkInfo -> [[MarkInfo]] -> BufferM ()+updateDependents' mark deps =+  case dependentSiblings mark deps of+    []   -> return ()+    deps' -> do+      txt <- markText mark+      forM_ deps' $ \d -> do+        dTxt <- markText d+        when (txt /= dTxt) $ setMarkText txt d++markText :: MarkInfo -> BufferM R.YiString+markText m = markRegion m >>= readRegionB++setMarkText :: R.YiString -> MarkInfo -> BufferM ()+setMarkText txt (SimpleMarkInfo _ start) = do+  p <- use $ markPointA start+  c <- readAtB p+  if isSpace c+    then insertNAt txt p+    else do+      r <- regionOfPartNonEmptyAtB unitViWordOnLine Forward p+      modifyRegionB (const txt) r++setMarkText txt mi = do+    start <- use $ markPointA $ startMark mi+    end   <- use $ markPointA $ endMark mi+    let r = mkRegion start end+    modifyRegionB (const txt) r+    when (start == end) $+      markPointA (endMark mi) .= end + Point (R.length txt)++withSimpleRegion :: MarkInfo -> (Region -> BufferM Region) -> BufferM Region+withSimpleRegion (SimpleMarkInfo _ s) f = do+    p <- use $ markPointA s+    c <- readAtB p+    if isSpace c+      then return $ mkRegion p p  -- return empty region+      else f =<< regionOfPartNonEmptyAtB unitViWordOnLine Forward p+withSimpleRegion r _ = error $ "withSimpleRegion: " <> show r++markRegion :: MarkInfo -> BufferM Region+markRegion m@SimpleMarkInfo{} = withSimpleRegion m $ \r -> do+    os <- findOverlappingMarksWith safeMarkRegion concat True r m+    rOs <- mapM safeMarkRegion os+    return . mkRegion (regionStart r) $ foldl' minEnd (regionEnd r) rOs+  where+    minEnd end r = if regionEnd r < end+                   then end+                   else min end $ regionStart r++markRegion m = liftM2 mkRegion+                   (use $ markPointA $ startMark m)+                   (use $ markPointA $ endMark m)++safeMarkRegion :: MarkInfo -> BufferM Region+safeMarkRegion m@(SimpleMarkInfo _ _) = withSimpleRegion m return+safeMarkRegion m = markRegion m++adjMarkRegion :: MarkInfo -> BufferM Region+adjMarkRegion s@(SimpleMarkInfo _ _) = markRegion s++adjMarkRegion m = do+    s <- use $ markPointA $ startMark m+    e <- use $ markPointA $ endMark m+    c <- readAtB e+    when (isWordChar c) $ do adjustEnding e+                             repairOverlappings e+    e' <- use $ markPointA $ endMark m+    s' <- adjustStart s e'+    return $ mkRegion s' e'+  where+    adjustEnding end = do+        r' <- regionOfPartNonEmptyAtB unitViWordOnLine Forward end+        markPointA (endMark m) .= (regionEnd r')++    adjustStart s e = do+        txt <- readRegionB (mkRegion s e)+        let sP = s + (Point . R.length $ R.takeWhile isSpace txt)+        when (sP > s) $+            markPointA (startMark m) .= sP+        return sP++    -- test if we generated overlappings and repair+    repairOverlappings origEnd = do overlappings <- allOverlappingMarks True m+                                    unless (null overlappings) $+                                        markPointA (endMark m) .= origEnd++findOverlappingMarksWith :: (MarkInfo -> BufferM Region)+                         -> ([[MarkInfo]] -> [MarkInfo])+                         -> Bool -> Region -> MarkInfo -> BufferM [MarkInfo]+findOverlappingMarksWith fMarkRegion flattenMarks border r m =+  let markFilter = filter (m /=) . flattenMarks . marks+      regOverlap = fmap (regionsOverlap border r) . fMarkRegion+  in fmap markFilter getBufferDyn >>= filterM regOverlap++findOverlappingMarks :: ([[MarkInfo]] -> [MarkInfo]) -> Bool -> Region ->+                        MarkInfo -> BufferM [MarkInfo]+findOverlappingMarks = findOverlappingMarksWith markRegion++regionsOverlappingMarks :: Bool -> Region -> MarkInfo -> BufferM [MarkInfo]+regionsOverlappingMarks = findOverlappingMarks concat++overlappingMarks :: Bool -> Bool -> MarkInfo -> BufferM [MarkInfo]+overlappingMarks border belongingTogether mark = do+    r <- markRegion mark+    findOverlappingMarks (if belongingTogether+                          then dependentSiblings mark+                          else concat)+                         border+                         r+                         mark++allOverlappingMarks :: Bool -> MarkInfo -> BufferM [MarkInfo]+allOverlappingMarks border = overlappingMarks border False++dependentOverlappingMarks :: Bool -> MarkInfo -> BufferM [MarkInfo]+dependentOverlappingMarks border = overlappingMarks border True++nextBufferMark :: Bool -> BufferM (Maybe MarkInfo)+nextBufferMark deleteLast = do+  BufferMarks ms <- getBufferDyn+  if null ms+    then return Nothing+    else do+      let mks = if deleteLast then const $ tail ms else (tail ms <>)+      putBufferDyn . BufferMarks . mks $ [head ms]+      return . Just $ head ms++isDependentMarker :: (MonadState FBuffer m, Functor m) => Mark -> m Bool+isDependentMarker bMark = do+    DependentMarks ms <- getBufferDyn+    return . elem bMark . concatMap bufferMarkers . concat $ ms++safeDeleteMarkB :: Mark -> BufferM ()+safeDeleteMarkB m = do+    b <- isDependentMarker m+    unless b (deleteMarkB m)++moveToNextBufferMark :: Bool -> BufferM ()+moveToNextBufferMark deleteLast = nextBufferMark deleteLast >>= \case+  Just p  -> mv p+  Nothing -> return ()+  where+    mv (SimpleMarkInfo _ m)   = do+        moveTo =<< use (markPointA m)+        when deleteLast $ safeDeleteMarkB m++    mv (ValuedMarkInfo _ s e) = do+        sp <- use $ markPointA s+        ep <- use $ markPointA e+        deleteRegionB (mkRegion sp ep)+        moveTo sp+        when deleteLast $ do+            safeDeleteMarkB s+            safeDeleteMarkB e++    mv r = error $ "moveToNextBufferMark.mv: " <> show r++-- Keymap support++newtype SupertabExt = Supertab (R.YiString -> Maybe (BufferM ()))++instance Monoid SupertabExt where+  mempty = Supertab $ const Nothing++  (Supertab f) `mappend` (Supertab g) =+    Supertab $ \s -> f s `mplus` g s++superTab :: (MonadInteract m Action Event) => Bool -> SupertabExt -> m ()+superTab caseSensitive (Supertab expander) =+    some (spec KTab ?>>! doSuperTab) >> deprioritize >>! resetComplete+  where+    doSuperTab = do canExpand <- withCurrentBuffer $ do+                                   sol <- atSol+                                   ws  <- hasWhiteSpaceBefore+                                   return $ sol || ws+                    if canExpand+                      then insertTab+                      else runCompleter++    insertTab = withCurrentBuffer $ mapM_ insertB =<< tabB++    runCompleter = do w <- withCurrentBuffer readPrevWordB+                      case expander w of+                        Just cmd -> withCurrentBuffer $ bkillWordB >> cmd+                        _        -> autoComplete++    autoComplete = wordCompleteString' caseSensitive >>=+                   withCurrentBuffer . (bkillWordB >>) . (insertN . R.fromText)++-- | Convert snippet description list into a SuperTab extension+fromSnippets :: Bool -> [(R.YiString, SnippetCmd ())] -> SupertabExt+fromSnippets deleteLast snippets =+  Supertab $ \str -> lookup str $ map (second $ runSnippet deleteLast) snippets++snippet :: MkSnippetCmd a b => a -> SnippetCmd b+snippet = mkSnippetCmd
+ src/Yi/Snippets/Haskell.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_HADDOCK show-extensions #-}++-- |+-- Module      :  Yi.Snippets.Haskell+-- License     :  GPL-2+-- Maintainer  :  yi-devel@googlegroups.com+-- Stability   :  experimental+-- Portability :  portable++module Yi.Snippets.Haskell where++import qualified Yi.Rope     as R (singleton)+import           Yi.Snippets (SnippetCmd, cursor, cursorWith, snippet, (&))++hsFunction :: SnippetCmd ()+hsFunction = snippet $+  cursorWith 1 (R.singleton 'f') & " :: " & cursor 2 & "\n" &+  cursor 3 & " = " & cursor 4 & "\n"++hsClass :: SnippetCmd ()+hsClass = snippet $+  "class " & cursor 1 & " " & cursor 2 & " where\n  " & cursor 3
+ src/Yi/String.hs view
@@ -0,0 +1,147 @@+{-# 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
+ src/Yi/Syntax/Driver.hs view
@@ -0,0 +1,58 @@+{-# 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]
+ src/Yi/Syntax/Layout.hs view
@@ -0,0 +1,147 @@+{-# 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.+
+ src/Yi/Syntax/OnlineTree.hs view
@@ -0,0 +1,43 @@+{-# 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
+ src/Yi/Syntax/Tree.hs view
@@ -0,0 +1,424 @@+{-# 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       (Posn (Posn, posnLine, posnOfs),+                                      Tok (Tok, tokPosn), tokBegin, tokEnd)+import           Yi.Region           (Region (regionEnd, regionStart),+                                      includedRegion, mkRegion)+import           Yi.String           (showT)++#ifdef TESTING+import           Test.QuickCheck+import           Test.QuickCheck.Property (unProperty)+#endif++-- 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)+++----------------------------------------------------+-- Testing code.++#ifdef TESTING++nodeRegion :: IsTree tree => Node (tree (Tok a)) -> Region+nodeRegion n = subtreeRegion t+    where Just t = walkDown n++data Test a = Empty | Leaf a | Bin (Test a) (Test a) deriving (Show, Eq, Foldable)++instance IsTree Test where+    uniplate (Bin l r) = ([l,r],\[l',r'] -> Bin l' r')+    uniplate t = ([],\[] -> t)+    emptyNode = Empty++type TT = Tok ()++instance Arbitrary (Test TT) where+    arbitrary = sized $ \size -> do+      arbitraryFromList [1..size+1]+    shrink (Leaf _) = []+    shrink (Bin l r) = [l,r] <>  (Bin <$> shrink l <*> pure r) <>  (Bin <$> pure l <*> shrink r)++tAt :: Point -> TT+tAt idx =  Tok () 1 (Posn (idx * 2) 0 0)++arbitraryFromList :: [Int] -> Gen (Test TT)+arbitraryFromList [] = error "arbitraryFromList expects non empty lists"+arbitraryFromList [x] = pure (Leaf (tAt (fromIntegral x)))+arbitraryFromList xs = do+  m <- choose (1,length xs - 1)+  let (l,r) = splitAt m xs+  Bin <$> arbitraryFromList l <*> arbitraryFromList r++newtype NTTT = N (Node (Test TT)) deriving Show++instance Arbitrary NTTT where+    arbitrary = do+      t <- arbitrary+      p <- arbitraryPath t+      return $ N (p,t)++arbitraryPath :: Test t -> Gen Path+arbitraryPath (Leaf _) = return []+arbitraryPath (Bin l r) = do+  c <- choose (0,1)+  let Just n' = index c [l,r]+  (c :) <$> arbitraryPath n'++regionInside :: Region -> Gen Region+regionInside r = do+  b :: Int <- choose (fromIntegral $ regionStart r, fromIntegral $ regionEnd r)+  e :: Int <- choose (b, fromIntegral $ regionEnd r)+  return $ mkRegion (fromIntegral b) (fromIntegral e)++pointInside :: Region -> Gen Point+pointInside r = do+  p :: Int <- choose (fromIntegral $ regionStart r, fromIntegral $ regionEnd r)+  return (fromIntegral p)++prop_fromLeafAfterToFinal :: NTTT -> Property+prop_fromLeafAfterToFinal (N n) = let+    fullRegion = subtreeRegion $ snd n+ in forAll (pointInside fullRegion) $ \p -> do+   let final@(_, (_, finalSubtree)) = fromLeafAfterToFinal p n+       finalRegion = subtreeRegion finalSubtree+       initialRegion = nodeRegion n++   whenFail (do putStrLn $ "final = " <> show final+                putStrLn $ "final reg = " <> show finalRegion+                putStrLn $ "initialReg = " <> show initialRegion+                putStrLn $ "p = " <> show p+            )+     ((regionStart finalRegion <= p) && (initialRegion `includedRegion` finalRegion))++prop_allLeavesAfter :: NTTT -> Property+prop_allLeavesAfter (N n@(xs,t)) = property $ do+  let after = allLeavesRelative afterChild n+  (xs',t') <- elements after+  let t'' = walkDown (xs',t)+  unProperty $ whenFail (do+      putStrLn $ "t' = " <> show t'+      putStrLn $ "t'' = " <> show t''+      putStrLn $ "xs' = " <> show xs'+    ) (Just t' == t'' && xs <= xs')++prop_allLeavesBefore :: NTTT -> Property+prop_allLeavesBefore (N n@(xs,t)) = property $ do+  let after = allLeavesRelative beforeChild n+  (xs',t') <- elements after+  let t'' = walkDown (xs',t)+  unProperty $ whenFail (do+      putStrLn $ "t' = " <> show t'+      putStrLn $ "t'' = " <> show t''+      putStrLn $ "xs' = " <> show xs'+    ) (Just t' == t'' && xs' <= xs)++prop_fromNodeToLeafAfter :: NTTT -> Property+prop_fromNodeToLeafAfter (N n) = forAll (pointInside (subtreeRegion $ snd n)) $ \p -> do+   let after = fromLeafToLeafAfter p n+       afterRegion = nodeRegion after+   whenFail (do putStrLn $ "after = " <> show after+                putStrLn $ "after reg = " <> show afterRegion+            )+     (regionStart afterRegion >= p)++prop_fromNodeToFinal :: NTTT -> Property+prop_fromNodeToFinal  (N t) = forAll (regionInside (subtreeRegion $ snd t)) $ \r -> do+   let final@(_, finalSubtree) = fromNodeToFinal r t+       finalRegion = subtreeRegion finalSubtree+   whenFail (do putStrLn $ "final = " <> show final+                putStrLn $ "final reg = " <> show finalRegion+                putStrLn $ "leaf after = " <> show (fromLeafToLeafAfter (regionEnd r) t)+            ) $ do+     r `includedRegion` finalRegion++#endif
+ src/Yi/Tab.hs view
@@ -0,0 +1,113 @@+{-# 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)
+ src/Yi/Tag.hs view
@@ -0,0 +1,152 @@+{-# 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, pack, unpack, words)+import qualified Data.Text.Encoding     as E (decodeUtf8, encodeUtf8)+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
+ src/Yi/TextCompletion.hs view
@@ -0,0 +1,211 @@+{-# 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 occurences 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.+-}
+ src/Yi/Types.hs view
@@ -0,0 +1,464 @@+{-# 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           Control.Monad.Reader           (MonadReader, ReaderT, ask, asks, runReaderT)+import           Control.Monad.RWS.Strict       (MonadWriter, RWS, ap, liftM3, void)+import           Control.Monad.State            (MonadState (..), State, forever, runState)+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                       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           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 (ConverterName, 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)++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 <left>, 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 :: RWS Window [Update] FBuffer a }+    deriving (Monad, Functor, MonadWriter [Update], MonadState FBuffer, MonadReader Window, Typeable)++-- | 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)++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)+    -- ^ prefered column to arrive at when we do a lineDown / lineUp+    , preferVisCol :: !(Maybe Int)+    -- ^ prefered column to arrive at visually (ie, respecting wrap)+    , stickyEol :: !Bool+    -- ^ stick to the end of line (used by vim bindings mostly)+    , pendingUpdates :: ![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 :: !(WindowRef -> Bool)+    , updateTransactionInFlight :: !Bool+    , updateTransactionAccum :: ![Update]+    , fontsizeVariation :: !Int+    , encodingConverterName :: Maybe R.ConverterName+      -- ^ How many points (frontend-specific) to change+      -- the font by in this buffer+    } 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 cn) = 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 cn+    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 (const False) <*> 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++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+  , modeAdjustBlock :: syntax -> Int -> BufferM ()+    -- ^ adjust the indentation after modification+  , 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++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+  }+++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 :: [[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
+ src/Yi/UI/Common.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE Rank2Types #-}++module Yi.UI.Common where++{- | 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 preparaed for this: for instance, Gtk-based frontends+should wrap GUI updates in @postGUIAsync@.+-}+data UI e = UI+    { main                  :: IO ()               -- ^ Main loop+    , end                   :: Bool -> IO ()       -- ^ Clean up, and also terminate if given 'true'+    , 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 ())+  }
+ src/Yi/UI/SimpleLayout.hs view
@@ -0,0 +1,177 @@+{-# 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
+ src/Yi/UI/TabBar.hs view
@@ -0,0 +1,55 @@+{-# 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
+ src/Yi/UI/Utils.hs view
@@ -0,0 +1,116 @@+{-# 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 neccessary.+--   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
+ src/Yi/Window.hs view
@@ -0,0 +1,80 @@+{-# 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
+ test/Spec.hs view
@@ -0,0 +1,15 @@+import Test.Tasty++import qualified Yi.CompletionTreeTests as CompletionTree (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" +  [ CompletionTree.testSuite+  , Tag.testSuite+  , Mode.Common.testSuite+  ]
+ test/Yi/CompletionTreeTests.hs view
@@ -0,0 +1,52 @@+module 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"])+      ]+  ]
+ test/Yi/Mode/CommonTests.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Yi.Mode.CommonTests (testSuite) where++import Test.Tasty+import Test.Tasty.QuickCheck+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+      ]+  ]
+ test/Yi/TagTests.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+module Yi.TagTests (testSuite) where++import Test.Tasty+import Test.Tasty.QuickCheck+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.cabal view
@@ -0,0 +1,242 @@+-- This file has been generated from package.yaml by hpack version 0.14.0.+--+-- see: https://github.com/sol/hpack++name:           yi-core+version:        0.13+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 <yi-devel@googlegroups.com>+license:        GPL-2+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/yi-editor/yi++flag eventlog+  description: Runtime binary will be compiled with eventlog and RTS options enabled.+  manual: True+  default: False++flag hint+  description: Include hint (haskell interpreter) in yi+  manual: True+  default: False++flag profiling+  description: Runtime binary will be compiled with profiling and RTS options enabled.+  manual: True+  default: False++flag testing+  description: bake-in the self-checks+  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+    , dyre >= 0.8.11+    , exceptions+    , filepath >= 1.1+    , hashable >= 1.1.2.5+    , Hclip >= 3+    , 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+    , safe >= 0.3.4+    , semigroups+    , split >= 0.2+    , text >= 1.1.1.3+    , text-icu >= 0.7+    , time >= 1.1+    , transformers-base+    , unix-compat >= 0.1+    , unordered-containers >= 0.1.3+    , word-trie >= 0.2.0.4+    , xdg-basedir >= 0.2.1+    , yi-language >= 0.1.1.0+    , yi-rope >= 0.7.0.0+  if os(win32)+    build-depends:+        Win32+  else+    build-depends:+        unix+  if flag(profiling)+    cpp-options: -DPROFILING+  if flag(eventlog)+    ghc-options: -Wall -fno-warn-orphans -eventlog+    cpp-options: -DEVENTLOG+  if flag(hint)+    cpp-options: -DHINT+    build-depends:+        hint > 0.3.1+  if flag(testing)+    cpp-options: -DTESTING+    build-depends:+        QuickCheck >= 2.7+      , random+  exposed-modules:+      Yi+      Yi.Boot+      Yi.Boot.Internal+      Yi.Buffer+      Yi.Buffer.Adjusted+      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.Main+      Yi.MiniBuffer+      Yi.Misc+      Yi.Mode.Common+      Yi.Mode.Compilation+      Yi.Mode.Interactive+      Yi.Monad+      Yi.Option+      Yi.Paths+      Yi.PersistentState+      Yi.Process+      Yi.Rectangle+      Yi.Snippets+      Yi.Snippets.Haskell+      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.SimpleLayout+      Yi.UI.TabBar+      Yi.UI.Utils+      Yi.Window+      System.FriendlyPath+  other-modules:+      Control.Exc+      Data.DelayList+      Parser.Incremental+      System.CanonicalizePath+      Yi.Buffer.Implementation+      Paths_yi_core+  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+    , array+    , attoparsec+    , binary >= 0.7+    , bytestring >= 0.9.1+    , containers+    , data-default+    , directory+    , dlist >= 0.4.1+    , dynamic-state >= 0.1.0.5+    , dyre >= 0.8.11+    , exceptions+    , filepath >= 1.1+    , hashable >= 1.1.2.5+    , Hclip >= 3+    , 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+    , safe >= 0.3.4+    , semigroups+    , split >= 0.2+    , text >= 1.1.1.3+    , text-icu >= 0.7+    , time >= 1.1+    , transformers-base+    , unix-compat >= 0.1+    , unordered-containers >= 0.1.3+    , word-trie >= 0.2.0.4+    , xdg-basedir >= 0.2.1+    , yi-language >= 0.1.1.0+    , yi-rope >= 0.7.0.0+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , yi-core+    , text+    , containers+  if os(win32)+    build-depends:+        Win32+  else+    build-depends:+        unix+  other-modules:+      Yi.CompletionTreeTests+      Yi.Mode.CommonTests+      Yi.TagTests+  default-language: Haskell2010