yi 0.4.6.2 → 0.5.0.1
raw patch · 72 files changed
+1784/−1858 lines, 72 files
Files
- Data/ByteRope.hs +7/−10
- HConf.hs +28/−23
- Main.hs +1/−1
- Yi.hs +0/−18
- Yi/Boot.hs +24/−14
- Yi/Boot.hs-boot +5/−0
- Yi/Buffer.hs +22/−764
- Yi/Buffer.hs-boot +0/−5
- Yi/Buffer/Basic.hs +7/−0
- Yi/Buffer/HighLevel.hs +2/−5
- Yi/Buffer/Implementation.hs +59/−52
- Yi/Buffer/Indent.hs +8/−8
- Yi/Buffer/Misc.hs +830/−0
- Yi/Buffer/Normal.hs +17/−19
- Yi/Buffer/Region.hs +1/−1
- Yi/Buffer/Undo.hs +179/−0
- Yi/Completion.hs +4/−1
- Yi/Config.hs +5/−26
- Yi/Core.hs +13/−11
- Yi/Dired.hs +28/−39
- Yi/Dynamic.hs +9/−5
- Yi/Editor.hs +19/−24
- Yi/Eval.hs +0/−6
- Yi/File.hs +2/−9
- Yi/GHC.hs +1/−5
- Yi/History.hs +1/−5
- Yi/IncrementalParse.hs +1/−1
- Yi/Interpreter.hs +1/−3
- Yi/Keymap/Cua.hs +13/−11
- Yi/Keymap/Emacs.hs +4/−16
- Yi/Keymap/Emacs/KillRing.hs +0/−2
- Yi/Keymap/Emacs/Utils.hs +0/−14
- Yi/Keymap/Vim.hs +56/−47
- Yi/KillRing.hs +19/−2
- Yi/Lexer/Alex.hs +1/−2
- Yi/Lexer/Haskell.x +3/−3
- Yi/Lexer/Latex.x +5/−5
- Yi/Lexer/LiterateHaskell.x +1/−1
- Yi/Lexer/Perl.x +8/−8
- Yi/Main.hs +10/−35
- Yi/MiniBuffer.hs +5/−13
- Yi/Misc.hs +8/−6
- Yi/Mode/Compilation.hs +0/−5
- Yi/Mode/Haskell.hs +3/−11
- Yi/Mode/Interactive.hs +0/−8
- Yi/Mode/Shim.hs +2/−2
- Yi/Modes.hs +14/−15
- Yi/Process.hs +1/−1
- Yi/Rectangle.hs +0/−3
- Yi/Region.hs +7/−2
- Yi/Search.hs +29/−36
- Yi/Style.hs +44/−57
- Yi/Style/Library.hs +36/−45
- Yi/Syntax/Fractal.hs +0/−1
- Yi/Syntax/Latex.hs +3/−2
- Yi/Syntax/Layout.hs +1/−1
- Yi/TextCompletion.hs +1/−8
- Yi/UI/Cocoa.hs +17/−21
- Yi/UI/Cocoa/TextStorage.hs +14/−29
- Yi/UI/Cocoa/TextView.hs +0/−1
- Yi/UI/Cocoa/Utils.hs +8/−13
- Yi/UI/Common.hs +11/−1
- Yi/UI/Gtk.hs +67/−65
- Yi/UI/Pango.hs +4/−12
- Yi/UI/TabBar.hs +3/−3
- Yi/UI/Utils.hs +15/−7
- Yi/UI/Vty.hs +55/−97
- Yi/Undo.hs +0/−180
- Yi/Window.hs +17/−1
- Yi/WindowSet.hs +18/−5
- examples/yi-simple.hs +3/−3
- yi.cabal +4/−3
Data/ByteRope.hs view
@@ -42,7 +42,8 @@ chunkSize :: Int chunkSize = 128 -newtype Size = Size { fromSize :: Int }+type Size = Sum Int -- use the additive monoid on Int+ newtype ByteRope = ByteRope { fromByteRope :: FingerTree Size ByteString } deriving (Eq, Show) @@ -54,12 +55,8 @@ t |- b | B.null b = t | otherwise = t |> b -instance Monoid Size where- mempty = Size 0- (Size n) `mappend` (Size m) = Size $ n + m- instance Measured Size ByteString where- measure = Size . B.length+ measure = Sum . B.length toLazyByteString :: ByteRope -> LB.ByteString toLazyByteString = LB.fromChunks . toList . fromByteRope@@ -118,7 +115,7 @@ -- | Get the length of the standard string. length :: ByteRope -> Int-length = fromSize . measure . fromByteRope+length = getSum . measure . fromByteRope -- | Append two strings by merging the two finger trees. append :: ByteRope -> ByteRope -> ByteRope@@ -143,8 +140,8 @@ let (lx, rx) = B.splitAt n' x in (ByteRope $ l |- lx, ByteRope $ rx -| r) _ -> (ByteRope l, ByteRope c) where- (l, c) = T.split ((> n) . fromSize) t- n' = n - fromSize (measure l)+ (l, c) = T.split ((> n) . getSum) t+ n' = n - getSum (measure l) -- | Count the number of occurrences of the specified character. count :: Word8 -> ByteRope -> Int@@ -161,7 +158,7 @@ where treeEIE :: FingerTree Size ByteString -> [Int] treeEIE t = case T.viewr t of- l :> s -> fmap (+ fromSize (measure l)) (L.reverse (B.elemIndices x s)) ++ treeEIE l+ l :> s -> fmap (+ getSum (measure l)) (L.reverse (B.elemIndices x s)) ++ treeEIE l EmptyR -> [] -- | Get all indices of the specified character
HConf.hs view
@@ -1,4 +1,4 @@-module HConf where+module HConf (getHConf, HConf(HConf), hconfOptions) where import Prelude hiding ( catch ) import Control.Exception (catch, bracket)@@ -23,8 +23,7 @@ import System.Exit import System.Environment import System.Console.GetOpt -import Data.Monoid-import System.FilePath ((</>))+import System.FilePath ((</>), takeDirectory) {- @@ -84,7 +83,7 @@ ) ] -getHConf :: String -> state -> (String -> IO state) -> (state -> IO String) ->+getHConf :: String -> state -> (FilePath -> IO state) -> (FilePath -> state -> IO ()) -> configuration -> (String -> configuration -> configuration) -> (configuration -> state -> IO ()) -> HConf state configuration@@ -113,9 +112,12 @@ -- This function will never return. , restart = \state -> do #ifndef mingw32_HOST_OS- s <- saveState state- let args = ["--resume", s]- executeFile projectName True args Nothing -- TODO: catch exceptions+ f <- getStateFile+ createDirectoryIfMissing True (takeDirectory f)+ saveState f state+ let args = ["--resume"]+ progName <- getProgName+ executeFile progName True args Nothing -- TODO: catch exceptions -- run the master, who will take care of recompiling; handle errors, etc. #else return ()@@ -125,11 +127,12 @@ , mainSlave = \userConfig -> do args <- getArgs state <- case args of- ["--resume", s] -> recoverState s- _ -> return initialState+ ["--resume"] -> recoverState =<< getStateFile+ _ -> return initialState realMain userConfig state - }+ } where+ getStateFile = (</> "status") <$> getProjectDir projectName -- Lift an IO action io :: MonadIO m => IO a -> m a@@ -201,8 +204,10 @@ where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing) --+(+++) :: Maybe [a] -> Maybe [a] -> Maybe [a]+Nothing +++ x = x+x +++ Nothing = x+(Just x) +++ (Just y) = Just (x ++ y) @@ -232,14 +237,17 @@ let executable_file = projectName ++ "-" ++ arch ++ "-" ++ os executable_path = dir </> executable_file putStrLn $ "Launching custom " ++ projectName ++ ": " ++ show executable_path-#ifndef darwin_HOST_OS+ let launchFailed = return $ Just + ("Custom " ++ projectName + ++ " (" ++ show executable_path ++ ") "+ ++ "could not be launched!\n") +++ errMsg++# ifndef darwin_HOST_OS handle (\_exception -> return ()) (executeFile executable_path False args' Nothing)- return $ Just - ("Custom " ++ projectName - ++ " (" ++ show executable_path ++ ") "- ++ "could not be launched!\n") `mappend` errMsg-#else+ -- if we reach this point then exec failed.+ launchFailed+# else -- Darwin is odd or broken; Take your pick. According to: -- http://uninformed.org/index.cgi?v=1&a=1&p=16 -- and@@ -249,14 +257,11 @@ child_pid <- forkProcess $ executeFile executable_path False args' Nothing child_status <- getProcessStatus True False child_pid case child_status of- Nothing -> return $ Just - ("Custom " ++ projectName - ++ " (" ++ show executable_path ++ ") "- ++ "could not be launched!\n") `mappend` errMsg+ Nothing -> launchFailed Just _ -> do exitImmediately ExitSuccess return Nothing-#endif+# endif #else return Nothing #endif
Main.hs view
@@ -2,7 +2,7 @@ -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons -- | "Real" Frontend to the static binary. This is merely calling the driver (see--- HConf)+-- Yi.Boot ~> HConf) module Main ( main ) where
Yi.hs view
@@ -12,44 +12,26 @@ module Yi (- module Control.Monad, -- since all actions are monadic, this is very useful to combine them.- module Control.Applicative, -- same reasoning module Data.Prototype, -- prototypes are mainly there for config; makes sense to export them. module Yi.Boot,- module Yi.Buffer,- module Yi.Buffer.HighLevel,- module Yi.Buffer.Normal, module Yi.Config, module Yi.Core,- module Yi.Debug, module Yi.Dired,- module Yi.Editor, module Yi.Eval, module Yi.File, module Yi.Main,- module Yi.Buffer.Region, module Yi.Search, module Yi.Style, module Yi.Style.Library,- module Yi.Keymap.Keys, ) where -import Control.Applicative-import Control.Monad hiding (mapM_, mapM) import Data.Prototype import Yi.Boot-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal-import Yi.Buffer.Region import Yi.Config import Yi.Core-import Yi.Debug import Yi.Dired-import Yi.Editor import Yi.Eval import Yi.File-import Yi.Keymap.Keys import Yi.Main (defaultConfig) import Yi.Search import Yi.Style
Yi/Boot.hs view
@@ -1,34 +1,44 @@ -- | Boot process of Yi, as an instanciation of HConf-module Yi.Boot (driver, yi) where+module Yi.Boot (driver, yi, reloadEditor) where -import Control.Monad+import Control.Monad.State+import qualified Data.Binary import HConf import Yi.Buffer.Basic import Yi.Config import Yi.Debug-import Yi.Editor (newBufferE)-import Yi.Keymap (makeAction)+import Yi.Editor (newBufferE, Editor, withEditor)+import Yi.Keymap (makeAction, YiM) import qualified Yi.Main -recoverState :: String -> IO ()-recoverState _stateName = return ()+recoverState :: FilePath -> IO (Maybe Editor)+recoverState path = do+ Data.Binary.decodeFile path -saveState :: () -> IO String-saveState _ = return ""+saveState :: FilePath -> Maybe Editor -> IO ()+saveState path ed = do+ Data.Binary.encodeFile path ed -realMain :: Config -> yiState -> IO ()-realMain staticConfig _state = do+realMain :: Config -> Maybe Editor -> IO ()+realMain staticConfig state = do when (debugMode staticConfig) $ initDebug ".yi.dbg" -- initialize here so we can see debug messages early, if -- the flag is set in the static configuration.- Yi.Main.main staticConfig+ Yi.Main.main staticConfig state -initState :: () -- TODO: Should be Editor-initState = ()+initState :: Maybe Editor+initState = Nothing +reloadEditor :: YiM ()+reloadEditor = do+ editor <- withEditor get+ liftIO $ restart (Just editor)++ driver :: IO () yi :: Config -> IO ()-HConf driver yi _ = getHConf Yi.Main.projectName initState recoverState saveState Yi.Main.defaultConfig showErrorsInConf realMain+restart :: Maybe Editor -> IO ()+HConf driver yi restart = getHConf Yi.Main.projectName initState recoverState saveState Yi.Main.defaultConfig showErrorsInConf realMain showErrorsInConf :: String -> Config -> Config showErrorsInConf errs conf
+ Yi/Boot.hs-boot view
@@ -0,0 +1,5 @@+module Yi.Boot where++import Yi.Keymap++reloadEditor :: YiM ()
Yi/Buffer.hs view
@@ -1,775 +1,33 @@-{-# OPTIONS -cpp #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, ExistentialQuantification, Rank2Types #-} --- Copyright (C) 2004, 2007 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (C) 2007, 2008 JP Bernardy+-- Copyright (C) 2008 JP Bernardy -- | 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- ( FBuffer (..)- , BufferM (..)- , WinMarks (..)- , getMarks- , runBuffer- , runBufferFull- , runBufferDummyWindow- , keyB- , curLn- , curCol- , sizeB- , pointB- , moveTo- , lineMoveRel- , lineUp- , lineDown- , newB- , MarkValue(..)- , Overlay, OvlLayer(..)- , mkOverlay- , gotoLn- , gotoLnFrom- , leftB- , rightB- , moveN- , leftN- , rightN- , insertN- , insertNAt- , insertB- , deleteN- , nelemsB- , nelemsB'- , writeB- , writeN- , deleteNAt- , deleteNBytes- , readB- , elemsB- , undosA- , undoB- , redoB- , getMarkB- , getMarkValueB- , setMarkPointB- , modifyMarkB- , newMarkB- , setVisibleSelection- , isUnchangedB- , isUnchangedBuffer- , setAnyMode- , setMode- , modifyMode- , regexB- , searchB- , readAtB- , getModeLine- , getPercent- , forgetPreferCol- , markSavedB- , addOverlayB- , delOverlayB- , delOverlayLayerB- , getDynamicB- , setDynamicB- , savingExcursionB- , savingPointB- , pendingUpdatesA- , highlightSelectionA- , revertPendingUpdatesB- , askWindow- , clearSyntax- , Mode (..)- , AnyMode(..)- , IndentBehaviour ( .. )- , emptyMode- , withModeB- , withSyntax0- , keymapProcessA- , strokesRangesB- , streamB- , getMarkPointB- , module Yi.Buffer.Basic- , pointAt- , fileA- , nameA- , pointDriveA+ ( 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.Undo+ -- Implementation re-exports (move out of implementation?)+ , UIUpdate (..)+ , Update (..)+ , updateIsDelete+ , toIndexedString ) where -import Prelude (ceiling)-import Yi.Prelude-import Yi.Region-import System.FilePath-import Yi.Regex (SearchExp)-import Yi.Accessor-import Yi.Buffer.Implementation-import Yi.Config-import Yi.Region-import Yi.Syntax-import Yi.Undo-import Yi.Dynamic-import Yi.Window-import Control.Monad.RWS.Strict hiding (mapM_, mapM, get, put)-import Data.Binary-import Data.List (scanl, takeWhile, zip, length)-import qualified Data.Map as M-import Data.Typeable-import {-# source #-} Yi.Keymap-import Yi.Monad-import Yi.Interact as I-import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8-import qualified Data.ByteString.Lazy as LB import Yi.Buffer.Basic--#ifdef TESTING-import Test.QuickCheck hiding (Config)-import Driver ()---- TODO: make this compile.---- instance Arbitrary FBuffer where--- arbitrary = do b0 <- return (newB 0 "*buffername*") `ap` (LazyUTF8.fromString `liftM` arbitrary)--- p0 <- arbitrary--- return $ snd $ runBuffer (dummyWindow $ bkey b0) b0 (moveTo $ Point p0)---- prop_replace_point b = snd $ runBufferDummyWindow b $ do--- p0 <- pointB--- replaceRegionB r--- p1 <- pointB--- return $ (p1 - p0) == ...-#endif---- In addition to Buffer's text, this manages (among others):--- * Log of updates mades--- * Undo--data WinMarks = WinMarks { fromMark, insMark, selMark, toMark :: !Mark }--data FBuffer = forall syntax.- FBuffer { name :: !String -- ^ immutable buffer name- , bkey :: !BufferRef -- ^ immutable unique key- , file :: !(Maybe FilePath) -- ^ maybe a filename associated with this buffer. Filename is canonicalized.- , undos :: !URList -- ^ undo/redo list- , rawbuf :: !(BufferImpl syntax)- , bmode :: !(Mode syntax)- -- , readOnly :: !Bool -- ^ a read-only bit (TODO)- , pointDrive :: !Bool- , bufferDynamic :: !DynamicValues -- ^ dynamic components- , preferCol :: !(Maybe Int) -- ^ prefered column to arrive at when we do a lineDown / lineUp- , pendingUpdates :: ![UIUpdate] -- ^ updates that haven't been synched in the UI yet- , highlightSelection :: !Bool- , process :: !KeymapProcess- , winMarks :: !(M.Map WindowRef WinMarks)- }- deriving Typeable------ | udpate the syntax information (clear the dirty "flag")-clearSyntax :: FBuffer -> FBuffer-clearSyntax = modifyRawbuf updateSyntax--modifyRawbuf :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> FBuffer -> FBuffer-modifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = - (FBuffer f1 f2 f3 f4 (f f5) f6 f7 f8 f9 f10 f11 f12 f13)--queryAndModifyRawbuf :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) ->- FBuffer -> (FBuffer, x)-queryAndModifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = - let (f5', x) = f f5- in (FBuffer f1 f2 f3 f4 f5' f6 f7 f8 f9 f10 f11 f12 f13, x)--pointDriveA :: Accessor FBuffer Bool-pointDriveA = Accessor pointDrive (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 (f f7) f8 f9 f10 f11 f12 f13)---undosA :: Accessor (FBuffer) (URList)-undosA = Accessor undos (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 (f f4) f5 f6 f7 f8 f9 f10 f11 f12 f13)--fileA :: Accessor (FBuffer) (Maybe FilePath)-fileA = Accessor file (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 (f f3) f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)--preferColA :: Accessor (FBuffer) (Maybe Int)-preferColA = Accessor preferCol (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 (f f9) f10 f11 f12 f13)--bufferDynamicA :: Accessor (FBuffer) (DynamicValues)-bufferDynamicA = Accessor bufferDynamic (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 (f f8) f9 f10 f11 f12 f13)--pendingUpdatesA :: Accessor (FBuffer) ([UIUpdate])-pendingUpdatesA = Accessor pendingUpdates (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 (f f10) f11 f12 f13)--highlightSelectionA :: Accessor FBuffer Bool-highlightSelectionA = Accessor highlightSelection (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 (f f11) f12 f13)--nameA :: Accessor FBuffer String-nameA = Accessor name (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer (f f1) f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)--keymapProcessA :: Accessor FBuffer KeymapProcess-keymapProcessA = Accessor process (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 (f f12) f13)--winMarksA :: Accessor FBuffer (M.Map Int WinMarks)-winMarksA = Accessor winMarks (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 (f f13))---data AnyMode = forall syntax. AnyMode (Mode syntax)- deriving Typeable--data Mode syntax = Mode- {- modeName :: String, -- ^ so this could be serialized, debugged.- modeApplies :: FilePath -> Bool, -- ^ What type of files does this mode apply to?- modeHL :: ExtHL syntax,- modePrettify :: syntax -> BufferM (),- modeKeymap :: KeymapEndo, -- ^ Buffer-local keymap modification- modeIndent :: syntax -> IndentBehaviour -> BufferM (),- modeAdjustBlock :: syntax -> Int -> BufferM (),- modeFollow :: syntax -> Action- }--instance Binary (Mode syntax) where- put = put . modeName -- we just store the modename.- get = do n <- get- return (emptyMode {modeName = n})--{-- Is 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.----- | 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, Typeable1)--deriving instance Typeable4 RWS--instance Applicative BufferM where- pure = return- (<*>) = ap--instance Eq FBuffer where- FBuffer { bkey = u } == FBuffer { bkey = v } = u == v--instance Show FBuffer where- showsPrec _ (FBuffer { bkey = u, name = f, undos = us }) = showString $ "Buffer #" ++ show u ++ " (" ++ show f ++ "..." ++ show us ++ ")"---- | Given a buffer, and some information update the modeline------ N.B. the contents of modelines should be specified by user, and--- not hardcoded.----getModeLine :: BufferM String-getModeLine = do- col <- curCol- pos <- pointB- ln <- curLn- p <- pointB- s <- sizeB- modeNm <- withModeB modeName- unchanged <- isUnchangedB- let pct = if pos == 1 then "Top" else getPercent p s- chg = if unchanged then "-" else "*"- nm <- gets name- return $- chg ++ " "- ++ nm ++- replicate 5 ' ' ++- "L" ++ show ln ++ " " ++ "C" ++ show col ++- " " ++ pct ++- " " ++ modeNm ++- " " ++ show (fromPoint p)---- | Given a point, and the file size, gives us a percent string-getPercent :: Point -> Point -> String-getPercent a b = show p ++ "%"- where p = ceiling ((fromIntegral a) / (fromIntegral b) * 100 :: Double) :: Int--queryBuffer :: (forall syntax. BufferImpl syntax -> x) -> (BufferM x)-queryBuffer f = gets (\(FBuffer _ _ _ _ fb _ _ _ _ _ _ _ _) -> f fb)--modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM ()-modifyBuffer f = modify (modifyRawbuf f)--queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x-queryAndModify f = getsAndModify (queryAndModifyRawbuf f)---- | Adds an "overlay" to the buffer-addOverlayB :: Overlay -> BufferM ()-addOverlayB ov = do- modifyA pendingUpdatesA (++ [overlayUpdate ov])- modifyBuffer $ addOverlayBI ov---- | Remove an existing "overlay"-delOverlayB :: Overlay -> BufferM ()-delOverlayB ov = do- modifyA pendingUpdatesA (++ [overlayUpdate ov])- modifyBuffer $ delOverlayBI ov--delOverlayLayerB :: OvlLayer -> BufferM ()-delOverlayLayerB l = do- modifyBuffer $ delOverlayLayer l---- | 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 w = do- getsA winMarksA (M.lookup $ wkey w) - -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- (i,s) <- case ms of- Just (WinMarks _ i s _) -> do- copyMark i staticInsMark- copyMark s staticSelMark- return (i,s)- Nothing -> do- -- copy marks from random window.- (_, WinMarks fr i s t) <- M.findMax <$> getA winMarksA- markValues <- mapM getMarkValueB [fr, i, s, t]- [newFrom, newIns, newSel, newTo] <- mapM newMarkB markValues- modifyA winMarksA (M.insert (wkey w) (WinMarks newFrom newIns newSel newTo))- return (newIns,newSel)- f <* copyMark staticInsMark i <* copyMark staticSelMark s- in (a, updates, modifier pendingUpdatesA (++ fmap TextUpdate updates) b')--copyMark :: Mark -> Mark -> BufferM ()-copyMark src dst = do- p <- getMarkValueB src- setMarkPointB dst (markPoint p)--getMarkValueB :: Mark -> BufferM MarkValue-getMarkValueB m = queryBuffer (getMarkValueBI m)--newMarkB :: MarkValue -> BufferM Mark-newMarkB v = queryAndModify $ newMarkBI v---- | 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 :: BufferM ()-markSavedB = modifyA undosA setSavedFilePointU--keyB :: FBuffer -> BufferRef-keyB (FBuffer { bkey = u }) = u--isUnchangedB :: BufferM Bool-isUnchangedB = gets isUnchangedBuffer--isUnchangedBuffer :: FBuffer -> Bool-isUnchangedBuffer = isAtSavedFilePointU . undos---undoRedo :: (forall syntax. URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update])) ) -> BufferM ()-undoRedo f = do- ur <- gets undos- (ur', updates) <- queryAndModify (f ur)- setA undosA ur'- tell updates--undoB :: BufferM ()-undoB = undoRedo undoU--redoB :: BufferM ()-redoB = undoRedo redoU--emptyMode :: Mode syntax-emptyMode = Mode- { - modeName = "empty",- modeApplies = const False,- modeHL = ExtHL noHighlighter,- modePrettify = \_ -> return (),- modeKeymap = id,- modeIndent = \_ _ -> return (),- modeAdjustBlock = \_ _ -> return (),- modeFollow = \_ -> emptyAction- }---- | Create buffer named @nm@ with contents @s@-newB :: Config -> BufferRef -> String -> LB.ByteString -> FBuffer-newB cfg unique nm s =- FBuffer { name = nm- , bkey = unique- , file = Nothing -- has name, not connected to a file- , undos = emptyU- , rawbuf = newBI s- -- , readOnly = False- , pointDrive = True- , bmode = emptyMode- , preferCol = Nothing- , bufferDynamic = modifier dynamicValueA (const $ configIndentSettings cfg) emptyDV - , pendingUpdates = []- , highlightSelection = False- , process = I.End- , winMarks = M.singleton dummyWindowKey (WinMarks dummyFromMark staticInsMark staticSelMark dummyToMark)- }---- | Point of eof-sizeB :: BufferM Point-sizeB = queryBuffer sizeBI---- | Extract the current point-pointB :: BufferM Point-pointB = queryBuffer pointBI---- | Return @n@ elems starting at @i@ of the buffer as a list-nelemsB :: Int -> Point -> BufferM [Char]-nelemsB n i = queryBuffer $ nelemsBI n i---- | Return @n@ bytes starting at @i@ of the buffer as a list, and convert it to a string.-nelemsB' :: Size -> Point -> BufferM [Char]-nelemsB' n i = queryBuffer $ nelemsBI' n i--streamB :: Direction -> Point -> BufferM LazyUTF8.ByteString-streamB dir i = queryBuffer (getStream dir i)--strokesRangesB :: Maybe SearchExp -> Point -> Point -> BufferM [[Stroke]]-strokesRangesB regex i j = queryBuffer $ strokesRangesBI regex i j----------------------------------------------------------------------------- Point based operations---- | Move point in buffer to the given index-moveTo :: Point -> BufferM ()-moveTo x = do- forgetPreferCol- modifyBuffer $ moveToI x----------------------------------------------------------------------------applyUpdate :: Update -> BufferM ()-applyUpdate update = do- valid <- queryBuffer (isValidUpdate update)- when valid $ do- forgetPreferCol- let reversed = reverseUpdateI update- modifyBuffer (applyUpdateI update)- modifyA undosA $ addChangeU $ AtomicChange $ reversed- tell [update]- -- otherwise, just ignore.---- | Revert all the pending updates; don't touch the point.-revertPendingUpdatesB :: BufferM ()-revertPendingUpdatesB = do- updates <- getA 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- off <- pointB- deleteNAt Forward 1 off- insertB c---- | Write the list into the buffer at current point.-writeN :: String -> BufferM ()-writeN cs = do- off <- pointB- deleteNAt Forward (length cs) off- insertNAt cs off------------------------------------------------------------------------------ | Insert the list at specified point, extending size of buffer-insertNAt :: [Char] -> Point -> BufferM ()-insertNAt cs pnt = applyUpdate (Insert pnt Forward $ LazyUTF8.fromString cs)---- | Insert the list at current point, extending size of buffer-insertN :: [Char] -> BufferM ()-insertN cs = insertNAt cs =<< pointB---- | Insert the char at current point, extending size of buffer-insertB :: Char -> BufferM ()-insertB = insertN . return------------------------------------------------------------------------------ | @deleteNAt n p@ deletes @n@ characters forwards from position @p@-deleteNAt :: Direction -> Int -> Point -> BufferM ()-deleteNAt dir n pos = do- els <- nelemsB n pos- applyUpdate (Delete pos dir $ LazyUTF8.fromString els)---- | @deleteNBytes n p@ deletes @n@ bytes forwards from position @p@-deleteNBytes :: Direction -> Size -> Point -> BufferM ()-deleteNBytes dir n pos = do- els <- LB.take (fromIntegral n) <$> streamB Forward pos- applyUpdate (Delete pos dir els)------------------------------------------------------------------------------ Line based editing---- | Return the current line number-curLn :: BufferM Int-curLn = queryBuffer curLnI---- | 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- (1 +) <$> gotoLnFrom (x - 1)--------------------------------------------------------------------------- | Return index of next (or previous) string in buffer that matches argument-searchB :: Direction -> [Char] -> BufferM (Maybe Point)-searchB dir s = queryBuffer (searchBI dir s)--setMode0 :: forall syntax. Mode syntax -> FBuffer -> FBuffer-setMode0 m (FBuffer f1 f2 f3 f4 rb _ f7 f8 f9 f10 f11 f12 f13) =- (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m) rb) m f7 f8 f9 f10 f11 f12 f13)--modifyMode0 :: (forall syntax. Mode syntax -> Mode syntax) -> FBuffer -> FBuffer-modifyMode0 f (FBuffer f1 f2 f3 f4 rb m f7 f8 f9 f10 f11 f12 f13) =- let m' = f m- in (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m') rb) m' f7 f8 f9 f10 f11 f12 f13)----- | 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.- setA keymapProcessA I.End ---- | 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.- setA keymapProcessA I.End ---withMode0 :: (forall syntax. Mode syntax -> a) -> FBuffer -> a-withMode0 f FBuffer {bmode = m} = f m ---withModeB :: (forall syntax. Mode syntax -> a) -> BufferM a-withModeB f = gets (withMode0 f)- -withSyntax0 :: (forall syntax. Mode syntax -> syntax -> a) -> FBuffer -> a-withSyntax0 f FBuffer {bmode = m, rawbuf = rb} = f m (getAst rb)- ---- | 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- queryBuffer (regexBI rx (mkRegion p (case dir of Forward -> s; Backward -> 0)))--------------------------------------------------------------------------- | Set the given mark point.-setMarkPointB :: Mark -> Point -> BufferM ()-setMarkPointB m pos = modifyMarkB m (\v -> v {markPoint = pos})--modifyMarkB :: Mark -> (MarkValue -> MarkValue) -> BufferM ()-modifyMarkB m f = modifyBuffer $ modifyMarkBI m f---setVisibleSelection :: Bool -> BufferM ()-setVisibleSelection = setA highlightSelectionA--getMarkB :: Maybe String -> BufferM Mark-getMarkB m = queryAndModify (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- p <- pointB- nextPoint <- queryBuffer (findNextChar n p)- moveTo nextPoint---- | 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--setPrefCol :: Maybe Int -> BufferM ()-setPrefCol = setA preferColA---- | 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 n = do- prefCol <- getA preferColA- targetCol <- case prefCol of- Nothing -> curCol- Just x -> return x- ofs <- gotoLnFrom n- gotoLnFrom 0 -- make sure we are at the start of line.- solPnt <- pointB- chrs <- nelemsB maxBound solPnt -- get all chars in the buffer, lazily.- let cols = scanl colMove 0 chrs -- columns corresponding to the char- let toSkip = takeWhile (\(char,col) -> char /= '\n' && col < targetCol) (zip chrs cols)- moveN (length toSkip)- setPrefCol (Just targetCol)- return ofs--forgetPreferCol :: BufferM ()-forgetPreferCol = setPrefCol Nothing--savingPrefCol :: BufferM a -> BufferM a-savingPrefCol f = do- pc <- gets preferCol- result <- f- setPrefCol pc- return result---- | Move point up one line-lineUp :: BufferM ()-lineUp = lineMoveRel (-1) >> return ()---- | Move point down one line-lineDown :: BufferM ()-lineDown = lineMoveRel 1 >> return ()---- | Return the contents of the buffer as a list-elemsB :: BufferM [Char]-elemsB = nelemsB maxBound 0---- | 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 = do- s <- nelemsB 1 i- return $ case s of- [c] -> c- _ -> '\0'---- | Delete @n@ characters forward from the current point-deleteN :: Int -> BufferM ()-deleteN n = pointB >>= deleteNAt Forward n------------------------------------------------------------------------------- | 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 = do - chars <- queryBuffer charsFromSolBI- return (foldl colMove 0 chars)--colMove :: Int -> Char -> Int-colMove col '\t' = (col + 7) `mod` 8-colMove col _ = col + 1- ---- | 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 = queryAndModify $ gotoLnRelI x--bufferDynamicValueA :: Initializable a => Accessor FBuffer a-bufferDynamicValueA = dynamicValueA .> bufferDynamicA--getDynamicB :: Initializable a => BufferM a-getDynamicB = getA bufferDynamicValueA---- | Insert a value into the extensible state, keyed by its type-setDynamicB :: Initializable a => a -> BufferM ()-setDynamicB = setA bufferDynamicValueA----- | 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 =<< getMarkPointB m- return res--getMarkPointB :: Mark -> BufferM Point-getMarkPointB m = markPoint <$> getMarkValueB m---- | 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--pointAt :: forall a. BufferM a -> BufferM Point-pointAt f = savingPointB (f *> pointB)------------------ Window--askWindow :: (Window -> a) -> BufferM a-askWindow = asks+import Yi.Buffer.HighLevel+import Yi.Buffer.Indent+import Yi.Buffer.Misc+import Yi.Buffer.Normal+import Yi.Buffer.Region+import Yi.Buffer.Undo +import Yi.Buffer.Implementation
− Yi/Buffer.hs-boot
@@ -1,5 +0,0 @@-module Yi.Buffer where--data AnyMode--data Mode syntax
Yi/Buffer/Basic.hs view
@@ -26,6 +26,13 @@ mayReverse Forward = id mayReverse Backward = reverse +-- | 'direction' is in the same style of 'maybe' or 'either' functions,+-- It takes one argument per direction (backward, then forward) and a+-- direction to select the output.+direction :: a -> a -> Direction -> a+direction b _ Backward = b+direction _ f Forward = f+ -- | A mark in a buffer newtype Mark = Mark {markId::Int} deriving (Eq, Ord, Show, Typeable, Binary) staticInsMark, staticSelMark :: Mark
Yi/Buffer/HighLevel.hs view
@@ -7,14 +7,13 @@ import Control.Applicative import Control.Monad.RWS.Strict (ask) import Control.Monad.State-import Data.Binary import Data.Char-import Data.Dynamic import Data.List (isPrefixOf, sort, lines, drop, filter, length, takeWhile, dropWhile) import Data.Maybe ( fromMaybe, listToMaybe ) -import Yi.Buffer+import Yi.Buffer.Basic+import Yi.Buffer.Misc import Yi.Buffer.Implementation (newLine) import Yi.Buffer.Normal import Yi.Buffer.Region@@ -348,8 +347,6 @@ instance Initializable SelectionStyle where initial = SelectionStyle Character--instance Binary SelectionStyle getRawSelectRegionB :: BufferM Region getRawSelectRegionB = do
Yi/Buffer/Implementation.hs view
@@ -35,7 +35,7 @@ -- , offsetFromSolBI , charsFromSolBI , searchBI- , regexBI+ , regexRegionBI , getMarkBI , modifyMarkBI , getMarkValueBI@@ -51,7 +51,9 @@ , strokesRangesBI , toIndexedString , getStream+ , getIndexedStream , newLine+ , SearchExp ) where @@ -74,14 +76,14 @@ import qualified Data.ByteString.Lazy as LazyB import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8+import qualified Codec.Binary.UTF8.Generic as UF8Codec import Yi.Buffer.Basic import Data.Array import Data.Char import Data.Maybe-import Data.List (groupBy)+import Data.List (groupBy, drop) import Data.Word import qualified Data.Set as Set-import Yi.Debug import Data.Typeable import Yi.Region @@ -153,8 +155,9 @@ updateSize :: Update -> Size updateSize = Size . fromIntegral . LazyB.length . updateString -data UIUpdate = TextUpdate Update+data UIUpdate = TextUpdate !Update | StyleUpdate !Point !Size+ deriving ({-! Binary !-}) -------------------------------------------------- -- Low-level primitives.@@ -241,6 +244,11 @@ getStream Forward (Point i) fb = F.toLazyByteString $ F.drop i $ mem $ fb getStream Backward (Point i) fb = F.toReverseLazyByteString $ F.take i $ mem $ fb +getIndexedStream :: Direction -> Point -> BufferImpl syntax -> [(Point,Char)]+getIndexedStream Forward (Point i) fb = toIndexedString Forward (Point i) $ F.toLazyByteString $ F.drop i $ mem $ fb+getIndexedStream Backward (Point i) fb = toIndexedString Backward (Point i) $ F.toReverseLazyByteString $ F.take i $ mem $ fb++ -- | Create an "overlay" for the style @sty@ between points @s@ and @e@ mkOverlay :: OvlLayer -> Region -> StyleName -> Overlay mkOverlay l r s = Overlay l (MarkValue (regionStart r) Backward) (MarkValue (regionEnd r) Forward) s@@ -268,18 +276,19 @@ -- 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.--- TODO: pass a region.-strokesRangesBI :: Maybe SearchExp -> Point -> Point -> BufferImpl syntax -> [[Stroke]]-strokesRangesBI regex i j fb@FBufferData {hlCache = HLState hl cache} = result+strokesRangesBI :: Maybe SearchExp -> Region -> BufferImpl syntax -> [[Stroke]]+strokesRangesBI regex rgn fb@(FBufferData {hlCache = HLState hl cache}) = result where+ i = regionStart rgn+ j = regionEnd rgn dropBefore = dropWhile (\(_l,_s,r) -> r <= i) takeIn = takeWhile (\(l,_s,_r) -> l <= j) - groundLayer = [(i,defaultStyle,j)]+ groundLayer = [(i,mempty,j)] syntaxHlLayer = hlGetStrokes hl point i j $ hlGetTree hl cache layers2 = map (map overlayStroke) $ groupBy ((==) `on` overlayLayer) $ Set.toList $ overlays fb layer3 = case regex of - Just re -> takeIn $ map hintStroke $ regexBI re (mkRegion i j) fb+ Just re -> takeIn $ map hintStroke $ regexRegionBI re (mkRegion i j) fb Nothing -> [] result = map (map clampStroke . takeIn . dropBefore) (layer3 : layers2 ++ [syntaxHlLayer, groundLayer]) overlayStroke (Overlay _ sm em a) = (markPoint sm, a, markPoint em)@@ -297,40 +306,13 @@ {-# INLINE moveToI #-} findNextChar :: Int -> Point -> BufferImpl syntax -> Point-findNextChar m (Point i) fb - | m == 0 = Point i- | m < 0 = let s = F.toReverseString $ F.take i $ mem fb- result = countBytes s (-m)- in Point (i - result)- | otherwise =- {-m > 0-} let s = F.toString $ F.drop i $ mem fb- result = countBytes0 s m- in Point (i + result)- ---- Count the number of bytes to skip @n@ UTF8 codepoints, forward-countBytes0 :: [Word8] -> Int -> Int-countBytes0 [] _ = 0-countBytes0 _ 0 = 0-countBytes0 (x:xs) m - | x < 128 = 1 + countBytes0 xs (m-1) -- one-byte codepoint- | x > 192 = 1 + countBytes1 xs m -- long code point; find the end of it.- | otherwise = 1 + countBytes0 xs m -- continuation; should not happen. skip.--countBytes1 :: [Word8] -> Int -> Int-countBytes1 [] _ = 0-countBytes1 (x:xs) m - | x < 128 || x > 192 = countBytes0 (x:xs) (m-1) -- beginning, long codepoint has ended.- | otherwise = 1 + countBytes1 xs m -- continuation----- Count the number of bytes to skip @n@ UTF8 codepoints, backwards.-countBytes :: [Word8] -> Int -> Int-countBytes [] _ = 0-countBytes _ 0 = 0-countBytes (x:xs) m - | x < 128 || x > 192 = 1 + countBytes xs (m-1) -- beginning of char, count one.- | otherwise = 1 + countBytes xs m -- continuation, just skip.+findNextChar m p fb + | m < 0 = case drop (0 - 1 - m) (getIndexedStream Backward p fb) of+ [] -> 0+ (i,_):_ -> i+ | otherwise = case drop m (getIndexedStream Forward p fb) of+ [] -> sizeBI fb+ (i,_):_ -> i -- | Checks if an Update is valid isValidUpdate :: Update -> BufferImpl syntax -> Bool@@ -463,8 +445,8 @@ -- | Return indices of all strings in buffer matching regex, inside the given region.-regexBI :: SearchExp -> Region -> forall syntax. BufferImpl syntax -> [Region]-regexBI (_,re) r fb = mayReverse (regionDirection r) $ +regexRegionBI :: SearchExp -> Region -> forall syntax. BufferImpl syntax -> [Region]+regexRegionBI (_,re) r fb = mayReverse (regionDirection r) $ fmap (fmapRegion addPoint . matchedRegion) $ matchAll re $ F.toLazyByteString $ F.take s $ F.drop p $ mem fb -- FIXME: lazy backward search is very inefficient with large regions. where matchedRegion arr = let (off,len) = arr!0 in mkRegion (Point off) (Point (off+len))@@ -504,16 +486,34 @@ hlCache = HLState hl (hlRun hl getText touchedIndex cache) } where getText = Scanner 0 id (error "getText: no character beyond eof")- (\idx -> toIndexedString idx (F.toLazyByteString (F.drop (fromPoint idx) (mem fb))))+ (\idx -> toIndexedString Forward idx (F.toLazyByteString (F.drop (fromPoint idx) (mem fb)))) -toIndexedString :: Point -> LazyB.ByteString -> [(Point, Char)]-toIndexedString curIdx bs = - case LazyUTF8.decode bs of+toIndexedString :: Direction -> Point -> LazyB.ByteString -> [(Point, Char)]+toIndexedString dir p = (case dir of+ Forward -> toIndexedStringForward+ Backward -> toIndexedStringBackward) p . LazyB.unpack++toIndexedStringForward :: Point -> [Word8] -> [(Point, Char)]+toIndexedStringForward curIdx bs = + case UF8Codec.decode bs of Nothing -> [] Just (c,n) -> let newIndex = curIdx + (fromIntegral n) in- (curIdx,c) : (newIndex `seq` (toIndexedString newIndex (LazyB.drop n bs)))- + (curIdx,c) : (newIndex `seq` (toIndexedStringForward newIndex (drop n bs)))+ +toIndexedStringBackward :: Point -> [Word8] -> [(Point,Char)]+toIndexedStringBackward curIdx bs = case UF8Codec.decode (reverse $ decodeBack bs) of+ Nothing -> []+ Just (c,n) -> let newIndex = curIdx - (fromIntegral n) in+ (newIndex,c) : (newIndex `seq` (toIndexedStringBackward newIndex (drop n bs)))+ +decodeBack :: [Word8] -> [Word8]+decodeBack [] = []+decodeBack (x:xs)+ | x < 128 || x > 192 = [x] -- beginning of char: take it and stop+ | otherwise = x : decodeBack xs -- continue++ insertGravity, selectionGravity :: Direction insertGravity = Forward selectionGravity = Backward@@ -546,7 +546,7 @@ -------------------------------------------------------- -- DERIVES GENERATED CODE -- DO NOT MODIFY BELOW THIS LINE--- CHECKSUM: 75413710+-- CHECKSUM: 1150468583 instance Binary MarkValue where put (MarkValue x1 x2) = return () >> (put x1 >> put x2)@@ -563,3 +563,10 @@ get = getWord8 >>= (\tag_ -> case tag_ of 0 -> ap (ap (ap (return Insert) get) get) get 1 -> ap (ap (ap (return Delete) get) get) get)++instance Binary UIUpdate+ where put (TextUpdate x1) = putWord8 0 >> put x1+ put (StyleUpdate x1 x2) = putWord8 1 >> (put x1 >> put x2)+ get = getWord8 >>= (\tag_ -> case tag_ of+ 0 -> ap (return TextUpdate) get+ 1 -> ap (ap (return StyleUpdate) get) get)
Yi/Buffer/Indent.hs view
@@ -9,15 +9,15 @@ import Control.Monad -import Yi.Buffer+import Yi.Buffer.Basic+import Yi.Buffer.Misc import Yi.Buffer.HighLevel--- import Yi.Debug-import Yi.Config+import Yi.Prelude import Yi.Buffer.Normal import Yi.Buffer.Region-+import Prelude () import Data.Char-import Data.List+import Data.List (span, length, sort, nub, break, reverse, filter, takeWhile) import Yi.String @@ -37,7 +37,7 @@ Retrieve the current indentation settings for the buffer. -} indentSettingsB :: BufferM IndentSettings-indentSettingsB = getDynamicB+indentSettingsB = withModeB (\Mode {modeIndentSettings = x} -> x) {-|@@ -366,7 +366,7 @@ let spacingOfChar :: Char -> Int spacingOfChar '\t' = tabSize indentSettings spacingOfChar _ = 1- return (sum $ map spacingOfChar text)+ return (sum $ fmap spacingOfChar text) {-| Indents the current line to the given indentation level. In addition moves the point according to where it was on the@@ -424,7 +424,7 @@ where (indents,rest) = span isSpace input countSpace '\t' = tabSize indentSettings countSpace _ = 1 -- we'll assume nothing but tabs and spaces- newCount = sum (map countSpace indents) + ((shiftWidth indentSettings) * numOfShifts)+ newCount = sum (fmap countSpace indents) + ((shiftWidth indentSettings) * numOfShifts) tabs = replicate (newCount `div` (tabSize indentSettings)) '\t' spaces = replicate (newCount `mod` (tabSize indentSettings)) ' '
+ Yi/Buffer/Misc.hs view
@@ -0,0 +1,830 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, ExistentialQuantification, Rank2Types #-}++-- Copyright (C) 2004, 2007 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (C) 2007, 2008 JP Bernardy++-- | The 'Buffer' module defines monadic editing operations over one-dimensional+-- buffers, maintaining a current /point/.++module Yi.Buffer.Misc+ ( FBuffer (..)+ , BufferM (..)+ , WinMarks (..)+ , getMarks+ , runBuffer+ , runBufferFull+ , runBufferDummyWindow+ , keyB+ , curLn+ , curCol+ , sizeB+ , pointB+ , moveTo+ , lineMoveRel+ , lineUp+ , lineDown+ , newB+ , MarkValue(..)+ , Overlay, OvlLayer(..)+ , mkOverlay+ , gotoLn+ , gotoLnFrom+ , leftB+ , rightB+ , moveN+ , leftN+ , rightN+ , insertN+ , insertNAt+ , insertB+ , deleteN+ , nelemsB+ , nelemsB'+ , writeB+ , writeN+ , deleteNAt+ , deleteNBytes+ , readB+ , elemsB+ , undosA+ , undoB+ , redoB+ , getMarkB+ , getMarkValueB+ , setMarkPointB+ , modifyMarkB+ , newMarkB+ , setVisibleSelection+ , isUnchangedB+ , isUnchangedBuffer+ , setAnyMode+ , setMode+ , setMode0+ , modifyMode+ , regexRegionB+ , regexB+ , searchB+ , readAtB+ , getModeLine+ , getPercent+ , forgetPreferCol+ , markSavedB+ , addOverlayB+ , delOverlayB+ , delOverlayLayerB+ , getDynamicB+ , setDynamicB+ , savingExcursionB+ , savingPointB+ , pendingUpdatesA+ , highlightSelectionA+ , revertPendingUpdatesB+ , askWindow+ , clearSyntax+ , Mode (..)+ , AnyMode (..)+ , IndentBehaviour (..)+ , IndentSettings (..)+ , emptyMode+ , withModeB+ , onMode+ , withSyntax0+ , withSyntaxB+ , keymapProcessA+ , strokesRangesB+ , streamB+ , indexedStreamB+ , getMarkPointB+ , pointAt+ , fileA+ , nameA+ , pointDriveA+ , SearchExp+ )+where++import Prelude (ceiling)+import Yi.Prelude+import Yi.Region+import System.FilePath+import Yi.Buffer.Implementation+import Yi.Region+import Yi.Syntax+import Yi.Buffer.Undo+import Yi.Dynamic+import Yi.Window+import Control.Monad.RWS.Strict hiding (mapM_, mapM, get, put)+import Data.Binary+import Data.List (scanl, takeWhile, zip, length)+import qualified Data.Map as M+import Data.Typeable+import {-# source #-} Yi.Keymap+import Yi.Monad+import Yi.Interact as I+import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8+import qualified Data.ByteString.Lazy as LB+import Yi.Buffer.Basic++#ifdef TESTING+import Test.QuickCheck hiding (Config)+import Driver ()++-- TODO: make this compile.++-- instance Arbitrary FBuffer where+-- arbitrary = do b0 <- return (newB 0 "*buffername*") `ap` (LazyUTF8.fromString `liftM` arbitrary)+-- p0 <- arbitrary+-- return $ snd $ runBuffer (dummyWindow $ bkey b0) b0 (moveTo $ Point p0)++-- prop_replace_point b = snd $ runBufferDummyWindow b $ do+-- p0 <- pointB+-- replaceRegionB r+-- p1 <- pointB+-- return $ (p1 - p0) == ...+#endif++-- In addition to Buffer's text, this manages (among others):+-- * Log of updates mades+-- * Undo++data WinMarks = WinMarks { fromMark, insMark, selMark, toMark :: !Mark }++instance Binary WinMarks where+ put (WinMarks f i s t) = put f >> put i >> put s >> put t+ get = WinMarks <$> get <*> get <*> get <*> get++data FBuffer = forall syntax.+ FBuffer { name :: !String -- ^ immutable buffer name+ , bkey :: !BufferRef -- ^ immutable unique key+ , file :: !(Maybe FilePath) -- ^ maybe a filename associated with this buffer. Filename is canonicalized.+ , undos :: !URList -- ^ undo/redo list+ , rawbuf :: !(BufferImpl syntax)+ , bmode :: !(Mode syntax)+ -- , readOnly :: !Bool -- ^ a read-only bit (TODO)+ , pointDrive :: !Bool+ , bufferDynamic :: !DynamicValues -- ^ dynamic components+ , preferCol :: !(Maybe Int) -- ^ prefered column to arrive at when we do a lineDown / lineUp+ , pendingUpdates :: ![UIUpdate] -- ^ updates that haven't been synched in the UI yet+ , highlightSelection :: !Bool+ , process :: !KeymapProcess+ , winMarks :: !(M.Map WindowRef WinMarks)+ }+ deriving Typeable++-- unfortunately the dynamic stuff can't be read.+instance Binary FBuffer where+ put (FBuffer n b f u r bmode pd _bd pc pu hs _proc wm) =+ let strippedRaw :: BufferImpl ()+ strippedRaw = (setSyntaxBI (modeHL emptyMode) r) + in do+ put (modeName bmode)+ put n >> put b >> put f >> put u >> put strippedRaw+ put pd >> put pc >> put pu >> put hs >> put wm+ + get = do+ mnm <- get+ FBuffer <$> get <*> get <*> get <*> get <*> getStripped <*>+ pure (emptyMode {modeName = mnm}) <*> get <*> pure emptyDV <*> get <*> get <*> get <*> pure I.End <*> get+ where getStripped :: Get (BufferImpl ())+ getStripped = get++-- | udpate the syntax information (clear the dirty "flag")+clearSyntax :: FBuffer -> FBuffer+clearSyntax = modifyRawbuf updateSyntax++modifyRawbuf :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> FBuffer -> FBuffer+modifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = + (FBuffer f1 f2 f3 f4 (f f5) f6 f7 f8 f9 f10 f11 f12 f13)++queryAndModifyRawbuf :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) ->+ FBuffer -> (FBuffer, x)+queryAndModifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = + let (f5', x) = f f5+ in (FBuffer f1 f2 f3 f4 f5' f6 f7 f8 f9 f10 f11 f12 f13, x)++pointDriveA :: Accessor FBuffer Bool+pointDriveA = Accessor pointDrive (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 (f f7) f8 f9 f10 f11 f12 f13)+++undosA :: Accessor (FBuffer) (URList)+undosA = Accessor undos (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 (f f4) f5 f6 f7 f8 f9 f10 f11 f12 f13)++fileA :: Accessor (FBuffer) (Maybe FilePath)+fileA = Accessor file (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 (f f3) f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)++preferColA :: Accessor (FBuffer) (Maybe Int)+preferColA = Accessor preferCol (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 (f f9) f10 f11 f12 f13)++bufferDynamicA :: Accessor (FBuffer) (DynamicValues)+bufferDynamicA = Accessor bufferDynamic (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 (f f8) f9 f10 f11 f12 f13)++pendingUpdatesA :: Accessor (FBuffer) ([UIUpdate])+pendingUpdatesA = Accessor pendingUpdates (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 (f f10) f11 f12 f13)++highlightSelectionA :: Accessor FBuffer Bool+highlightSelectionA = Accessor highlightSelection (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 (f f11) f12 f13)++nameA :: Accessor FBuffer String+nameA = Accessor name (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer (f f1) f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)++keymapProcessA :: Accessor FBuffer KeymapProcess+keymapProcessA = Accessor process (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 (f f12) f13)++winMarksA :: Accessor FBuffer (M.Map Int WinMarks)+winMarksA = Accessor winMarks (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 (f f13))++++{- | 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)++++data AnyMode = forall syntax. AnyMode (Mode syntax)+ deriving Typeable++data Mode syntax = Mode+ {+ modeName :: String, -- ^ so this could be serialized, debugged.+ modeApplies :: FilePath -> Bool, -- ^ What type of files does this mode apply to?+ modeHL :: ExtHL syntax,+ modePrettify :: syntax -> BufferM (),+ modeKeymap :: KeymapEndo, -- ^ Buffer-local keymap modification+ modeIndent :: syntax -> IndentBehaviour -> BufferM (),+ modeAdjustBlock :: syntax -> Int -> BufferM (),+ modeFollow :: syntax -> Action,+ modeIndentSettings :: IndentSettings+ }++instance Binary (Mode syntax) where+ put = put . modeName -- we just store the modename.+ get = do n <- get+ return (emptyMode {modeName = n})++{-+ Is 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.+++-- | 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, Typeable1)++deriving instance Typeable4 RWS++instance Applicative BufferM where+ pure = return+ (<*>) = ap++instance Eq FBuffer where+ FBuffer { bkey = u } == FBuffer { bkey = v } = u == v++instance Show FBuffer where+ showsPrec _ (FBuffer { bkey = u, name = f, undos = us }) = showString $ "Buffer #" ++ show u ++ " (" ++ show f ++ "..." ++ show us ++ ")"++-- | Given a buffer, and some information update the modeline+--+-- N.B. the contents of modelines should be specified by user, and+-- not hardcoded.+--+getModeLine :: BufferM String+getModeLine = do+ col <- curCol+ pos <- pointB+ ln <- curLn+ p <- pointB+ s <- sizeB+ modeNm <- withModeB modeName+ unchanged <- isUnchangedB+ let pct = if pos == 1 then "Top" else getPercent p s+ chg = if unchanged then "-" else "*"+ nm <- gets name+ return $+ chg ++ " "+ ++ nm +++ replicate 5 ' ' +++ "L" ++ show ln ++ " " ++ "C" ++ show col +++ " " ++ pct +++ " " ++ modeNm +++ " " ++ show (fromPoint p)++-- | Given a point, and the file size, gives us a percent string+getPercent :: Point -> Point -> String+getPercent a b = show p ++ "%"+ where p = ceiling ((fromIntegral a) / (fromIntegral b) * 100 :: Double) :: Int++queryBuffer :: (forall syntax. BufferImpl syntax -> x) -> (BufferM x)+queryBuffer f = gets (\(FBuffer _ _ _ _ fb _ _ _ _ _ _ _ _) -> f fb)++modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM ()+modifyBuffer f = modify (modifyRawbuf f)++queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x+queryAndModify f = getsAndModify (queryAndModifyRawbuf f)++-- | Adds an "overlay" to the buffer+addOverlayB :: Overlay -> BufferM ()+addOverlayB ov = do+ modifyA pendingUpdatesA (++ [overlayUpdate ov])+ modifyBuffer $ addOverlayBI ov++-- | Remove an existing "overlay"+delOverlayB :: Overlay -> BufferM ()+delOverlayB ov = do+ modifyA pendingUpdatesA (++ [overlayUpdate ov])+ modifyBuffer $ delOverlayBI ov++delOverlayLayerB :: OvlLayer -> BufferM ()+delOverlayLayerB l = do+ modifyBuffer $ delOverlayLayer l++-- | 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 w = do+ getsA winMarksA (M.lookup $ wkey w) + +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+ (i,s) <- case ms of+ Just (WinMarks _ i s _) -> do+ copyMark i staticInsMark+ copyMark s staticSelMark+ return (i,s)+ Nothing -> do+ -- copy marks from random window.+ (_, WinMarks fr i s t) <- M.findMax <$> getA winMarksA+ markValues <- mapM getMarkValueB [fr, i, s, t]+ [newFrom, newIns, newSel, newTo] <- mapM newMarkB markValues+ modifyA winMarksA (M.insert (wkey w) (WinMarks newFrom newIns newSel newTo))+ return (newIns,newSel)+ f <* copyMark staticInsMark i <* copyMark staticSelMark s+ in (a, updates, modifier pendingUpdatesA (++ fmap TextUpdate updates) b')++copyMark :: Mark -> Mark -> BufferM ()+copyMark src dst = do+ p <- getMarkValueB src+ setMarkPointB dst (markPoint p)++getMarkValueB :: Mark -> BufferM MarkValue+getMarkValueB m = queryBuffer (getMarkValueBI m)++newMarkB :: MarkValue -> BufferM Mark+newMarkB v = queryAndModify $ newMarkBI v++-- | 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 :: BufferM ()+markSavedB = modifyA undosA setSavedFilePointU++keyB :: FBuffer -> BufferRef+keyB (FBuffer { bkey = u }) = u++isUnchangedB :: BufferM Bool+isUnchangedB = gets isUnchangedBuffer++isUnchangedBuffer :: FBuffer -> Bool+isUnchangedBuffer = isAtSavedFilePointU . undos+++undoRedo :: (forall syntax. URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update])) ) -> BufferM ()+undoRedo f = do+ ur <- gets undos+ (ur', updates) <- queryAndModify (f ur)+ setA undosA ur'+ tell updates++undoB :: BufferM ()+undoB = undoRedo undoU++redoB :: BufferM ()+redoB = undoRedo redoU++emptyMode :: Mode syntax+emptyMode = Mode+ { + modeName = "empty",+ modeApplies = const False,+ modeHL = ExtHL noHighlighter,+ modePrettify = \_ -> return (),+ modeKeymap = id,+ modeIndent = \_ _ -> return (),+ modeAdjustBlock = \_ _ -> return (),+ modeFollow = \_ -> emptyAction,+ modeIndentSettings = IndentSettings + { expandTabs = True+ , tabSize = 8+ , shiftWidth = 4+ }+ }++-- | Create buffer named @nm@ with contents @s@+newB :: BufferRef -> String -> LB.ByteString -> FBuffer+newB unique nm s =+ FBuffer { name = nm+ , bkey = unique+ , file = Nothing -- has name, not connected to a file+ , undos = emptyU+ , rawbuf = newBI s+ -- , readOnly = False+ , pointDrive = True+ , bmode = emptyMode+ , preferCol = Nothing+ , bufferDynamic = emptyDV + , pendingUpdates = []+ , highlightSelection = False+ , process = I.End+ , winMarks = M.singleton dummyWindowKey (WinMarks dummyFromMark staticInsMark staticSelMark dummyToMark)+ }++-- | Point of eof+sizeB :: BufferM Point+sizeB = queryBuffer sizeBI++-- | Extract the current point+pointB :: BufferM Point+pointB = queryBuffer pointBI++-- | Return @n@ elems starting at @i@ of the buffer as a list+nelemsB :: Int -> Point -> BufferM [Char]+nelemsB n i = queryBuffer $ nelemsBI n i++-- | Return @n@ bytes starting at @i@ of the buffer as a list, and convert it to a string.+nelemsB' :: Size -> Point -> BufferM [Char]+nelemsB' n i = queryBuffer $ nelemsBI' n i++streamB :: Direction -> Point -> BufferM LazyUTF8.ByteString+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 = queryBuffer $ strokesRangesBI regex r++------------------------------------------------------------------------+-- Point based operations++-- | Move point in buffer to the given index+moveTo :: Point -> BufferM ()+moveTo x = do+ forgetPreferCol+ modifyBuffer $ moveToI x++------------------------------------------------------------------------++applyUpdate :: Update -> BufferM ()+applyUpdate update = do+ valid <- queryBuffer (isValidUpdate update)+ when valid $ do+ forgetPreferCol+ let reversed = reverseUpdateI update+ modifyBuffer (applyUpdateI update)+ modifyA undosA $ addChangeU $ AtomicChange $ reversed+ tell [update]+ -- otherwise, just ignore.++-- | Revert all the pending updates; don't touch the point.+revertPendingUpdatesB :: BufferM ()+revertPendingUpdatesB = do+ updates <- getA 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+ off <- pointB+ deleteNAt Forward 1 off+ insertB c++-- | Write the list into the buffer at current point.+writeN :: String -> BufferM ()+writeN cs = do+ off <- pointB+ deleteNAt Forward (length cs) off+ insertNAt cs off++------------------------------------------------------------------------++-- | Insert the list at specified point, extending size of buffer+insertNAt :: [Char] -> Point -> BufferM ()+insertNAt cs pnt = applyUpdate (Insert pnt Forward $ LazyUTF8.fromString cs)++-- | Insert the list at current point, extending size of buffer+insertN :: [Char] -> BufferM ()+insertN cs = insertNAt cs =<< pointB++-- | Insert the char at current point, extending size of buffer+insertB :: Char -> BufferM ()+insertB = insertN . return++------------------------------------------------------------------------++-- | @deleteNAt n p@ deletes @n@ characters forwards from position @p@+deleteNAt :: Direction -> Int -> Point -> BufferM ()+deleteNAt dir n pos = do+ els <- nelemsB n pos+ applyUpdate (Delete pos dir $ LazyUTF8.fromString els)++-- | @deleteNBytes n p@ deletes @n@ bytes forwards from position @p@+deleteNBytes :: Direction -> Size -> Point -> BufferM ()+deleteNBytes dir n pos = do+ els <- LB.take (fromIntegral n) <$> streamB Forward pos+ applyUpdate (Delete pos dir els)+++------------------------------------------------------------------------+-- Line based editing++-- | Return the current line number+curLn :: BufferM Int+curLn = queryBuffer curLnI++-- | 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+ (1 +) <$> gotoLnFrom (x - 1)++---------------------------------------------------------------------++-- | Return index of next (or previous) string in buffer that matches argument+searchB :: Direction -> [Char] -> BufferM (Maybe Point)+searchB dir s = queryBuffer (searchBI dir s)++setMode0 :: forall syntax. Mode syntax -> FBuffer -> FBuffer+setMode0 m (FBuffer f1 f2 f3 f4 rb _ f7 f8 f9 f10 f11 f12 f13) =+ (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m) rb) m f7 f8 f9 f10 f11 f12 f13)++modifyMode0 :: (forall syntax. Mode syntax -> Mode syntax) -> FBuffer -> FBuffer+modifyMode0 f (FBuffer f1 f2 f3 f4 rb m f7 f8 f9 f10 f11 f12 f13) =+ let m' = f m+ in (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m') rb) m' f7 f8 f9 f10 f11 f12 f13)+++-- | 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.+ setA keymapProcessA I.End +++-- | 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.+ setA 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 -> a) -> BufferM a+withModeB f = gets (withMode0 f)+ +withSyntax0 :: (forall syntax. Mode syntax -> syntax -> a) -> FBuffer -> a+withSyntax0 f FBuffer {bmode = m, rawbuf = rb} = f m (getAst rb)++withSyntaxB :: (forall syntax. Mode syntax -> syntax -> BufferM x) -> BufferM x+withSyntaxB f = do+ act <- gets (withSyntax0 f)+ act+ +-- | Return indices of next string 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))++---------------------------------------------------------------------++-- | Set the given mark point.+setMarkPointB :: Mark -> Point -> BufferM ()+setMarkPointB m pos = modifyMarkB m (\v -> v {markPoint = pos})++modifyMarkB :: Mark -> (MarkValue -> MarkValue) -> BufferM ()+modifyMarkB m f = modifyBuffer $ modifyMarkBI m f+++setVisibleSelection :: Bool -> BufferM ()+setVisibleSelection = setA highlightSelectionA++getMarkB :: Maybe String -> BufferM Mark+getMarkB m = queryAndModify (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+ p <- pointB+ nextPoint <- queryBuffer (findNextChar n p)+ moveTo nextPoint++-- | 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++setPrefCol :: Maybe Int -> BufferM ()+setPrefCol = setA preferColA++-- | 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 n = do+ prefCol <- getA preferColA+ targetCol <- case prefCol of+ Nothing -> curCol+ Just x -> return x+ ofs <- gotoLnFrom n+ gotoLnFrom 0 -- make sure we are at the start of line.+ solPnt <- pointB+ chrs <- nelemsB maxBound solPnt -- get all chars in the buffer, lazily.+ let cols = scanl colMove 0 chrs -- columns corresponding to the char+ let toSkip = takeWhile (\(char,col) -> char /= '\n' && col < targetCol) (zip chrs cols)+ moveN (length toSkip)+ setPrefCol (Just targetCol)+ return ofs++forgetPreferCol :: BufferM ()+forgetPreferCol = setPrefCol Nothing++savingPrefCol :: BufferM a -> BufferM a+savingPrefCol f = do+ pc <- gets preferCol+ result <- f+ setPrefCol pc+ return result++-- | Move point up one line+lineUp :: BufferM ()+lineUp = lineMoveRel (-1) >> return ()++-- | Move point down one line+lineDown :: BufferM ()+lineDown = lineMoveRel 1 >> return ()++-- | Return the contents of the buffer as a list+elemsB :: BufferM [Char]+elemsB = nelemsB maxBound 0++-- | 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 = do+ s <- nelemsB 1 i+ return $ case s of+ [c] -> c+ _ -> '\0'++-- | Delete @n@ characters forward from the current point+deleteN :: Int -> BufferM ()+deleteN n = pointB >>= deleteNAt Forward n++------------------------------------------------------------------------+++-- | 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 = do + chars <- queryBuffer charsFromSolBI+ return (foldl colMove 0 chars)++colMove :: Int -> Char -> Int+colMove col '\t' = (col + 7) `mod` 8+colMove col _ = col + 1+ ++-- | 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 = queryAndModify $ gotoLnRelI x++bufferDynamicValueA :: Initializable a => Accessor FBuffer a+bufferDynamicValueA = dynamicValueA .> bufferDynamicA++getDynamicB :: Initializable a => BufferM a+getDynamicB = getA bufferDynamicValueA++-- | Insert a value into the extensible state, keyed by its type+setDynamicB :: Initializable a => a -> BufferM ()+setDynamicB = setA bufferDynamicValueA+++-- | 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 =<< getMarkPointB m+ return res++getMarkPointB :: Mark -> BufferM Point+getMarkPointB m = markPoint <$> getMarkValueB m++-- | 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++pointAt :: forall a. BufferM a -> BufferM Point+pointAt f = savingPointB (f *> pointB)++-------------+-- Window++askWindow :: (Window -> a) -> BufferM a+askWindow = asks+
Yi/Buffer/Normal.hs view
@@ -17,7 +17,7 @@ moveB, maybeMoveB, transformB, transposeB, peekB, - regionOfB, regionOfPartB, regionOfPartNonEmptyB,+ regionOfB, regionOfNonEmptyB, regionOfPartB, regionOfPartNonEmptyB, readUnitB, untilB, doUntilB_, untilB_, whileB, atBoundaryB,@@ -27,7 +27,8 @@ checkPeekB ) where -import Yi.Buffer+import Yi.Buffer.Basic+import Yi.Buffer.Misc import Yi.Buffer.Region import Data.Char import Control.Applicative@@ -35,17 +36,18 @@ import Data.Typeable -- | Designate a given "unit" of text.-data TextUnit = Character- | Word+data TextUnit = Character -- ^ a single character+ | Word -- ^ a word as in use in Emacs (funamental mode) | ViWord -- ^ a word as in use in Vim | ViWORD -- ^ a WORD as in use in Vim | Line -- ^ a line of text (between newlines) | VLine -- ^ a "vertical" line of text (area of text between two characters at the same column number)- | Delimited Char Char- | Document+ | Delimited Char Char -- ^ delimited on the left and right by given characters+ | Document -- ^ the whole document | GenUnit {genEnclosingUnit :: TextUnit, genUnitBoundary :: Direction -> BufferM Bool}- -- (haddock, stay away) | Page | Searched+ -- there could be more text units, like Page, Searched, etc. it's probably a good+ -- idea to use GenUnit though. deriving Typeable isWordChar :: Char -> Bool@@ -54,7 +56,7 @@ isNl :: Char -> Bool isNl = (== '\n') --- A visible space is one that actually takes up space on screen. In other +-- | A visible space is one that actually takes up space on screen. In other -- words: everything but the newline. isVisSpace :: Char -> Bool isVisSpace c = (not $ isNl c) && (isSpace c)@@ -263,24 +265,20 @@ <$> indexAfterB (maybeMoveB unit Backward) <*> indexAfterB (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 = savingPointB $ do- b <- pointB- maybeMoveB unit dir- e <- pointB- return $ mkRegion b e+regionOfPartB unit dir = mkRegion <$> pointB <*> indexAfterB (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 = savingPointB $ do- b <- pointB- moveB unit dir- e <- pointB- return $ mkRegion b e-+regionOfPartNonEmptyB unit dir = mkRegion <$> pointB <*> indexAfterB (moveB unit dir) readUnitB :: TextUnit -> BufferM String readUnitB = readRegionB <=< regionOfB
Yi/Buffer/Region.hs view
@@ -19,7 +19,7 @@ where import Data.Algorithm.Diff import Yi.Region-import Yi.Buffer+import Yi.Buffer.Misc import Yi.Prelude import Prelude () import Data.List (length)
+ Yi/Buffer/Undo.hs view
@@ -0,0 +1,179 @@+-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2008 JP Bernardy++--+-- | 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 Control.Monad (ap)+import Data.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 {-! Binary !-})++-- | A URList consists of an undo and a redo list.+data URList = URList [Change] [Change]+ deriving (Show {-! Binary !-})++-- | 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 :: URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoU ur b = undoUntilInteractive [] (undoInteractive ur) b++-- | This redoes one iteraction step.+redoU :: 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 :: [Update] -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoUntilInteractive 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 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 xs ur' b'+ in (b'', (ur'', u:xs''))++-- | 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++++--------------------------------------------------------+-- DERIVES GENERATED CODE+-- DO NOT MODIFY BELOW THIS LINE+-- CHECKSUM: 809201852++instance Binary Change+ where put (SavedFilePoint) = putWord8 0+ put (InteractivePoint) = putWord8 1+ put (AtomicChange x1) = putWord8 2 >> put x1+ get = getWord8 >>= (\tag_ -> case tag_ of+ 0 -> return SavedFilePoint+ 1 -> return InteractivePoint+ 2 -> ap (return AtomicChange) get)++instance Binary URList+ where put (URList x1 x2) = return () >> (put x1 >> put x2)+ get = case 0 of+ 0 -> ap (ap (return URList) get) get
Yi/Completion.hs view
@@ -14,7 +14,10 @@ ------------------------------------------- -- General completion--------------------------------------------++-- | Return the longest common prefix of a set of strings.+-- > P(xs) === all (isPrefixOf (commonPrefix xs)) xs+-- > length s > length (commonPrefix xs) --> not (all (isPrefixOf s) xs) commonPrefix :: [String] -> String commonPrefix [] = [] commonPrefix strings
Yi/Config.hs view
@@ -3,16 +3,14 @@ import qualified Data.Map as M import Data.Prototype -import {-# source #-} Yi.Buffer+import Yi.Buffer import {-# source #-} Yi.Keymap import {-# source #-} Yi.Editor-import Yi.Dynamic import Data.Dynamic import Yi.Event import Yi.Style import Yi.Style.Library import {-# source #-} Yi.UI.Common-import Data.Binary data UIConfig = UIConfig { configFontName :: Maybe String, -- ^ Font name, for the UI that support it.@@ -29,26 +27,7 @@ configStyle :: UIConfig -> UIStyle configStyle = extractValue . configTheme -{- | 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 {-! Binary !-}) ----instance Initializable IndentSettings where- initial = error "IndentSettings should be initialized from Config."--instance Binary IndentSettings--- -- | Configuration record. All Yi hooks can be set here. data Config = Config {startFrontEnd :: UIBoot, -- ^ UI to use.@@ -60,17 +39,17 @@ -- ^ Default keymap to use. modeTable :: [AnyMode], -- ^ List modes by order of preference.- fundamentalMode :: (forall syntax. Mode syntax), publishedActions :: M.Map String [Data.Dynamic.Dynamic], -- ^ Actions available in the "interpreter" (akin to M-x in emacs) debugMode :: Bool, -- ^ Produce a .yi.dbg file with a lot of debug information.- configKillringAccumulate :: !Bool,+ configKillringAccumulate :: !Bool -- ^ Set to 'True' for an emacs-like behaviour, where -- all deleted text is accumulated in a killring.- configIndentSettings :: IndentSettings- -- IndentSettings should perhaps be in Mode? }++configFundamentalMode :: Config -> AnyMode+configFundamentalMode = last . modeTable type UIBoot = Config -> (Event -> IO ()) -> ([Action] -> IO ()) -> Editor -> IO UI
Yi/Core.hs view
@@ -13,11 +13,15 @@ -- * Keymap , module Yi.Keymap + , module Yi.Prelude+ , module Yi.Editor+ , module Yi.Buffer+ , module Yi.Keymap.Keys+ -- * Construction and destruction , startEditor , quitEditor -- :: YiM () - , reloadEditor -- :: YiM () , getAllNamesInScope , refreshEditor -- :: YiM ()@@ -45,19 +49,16 @@ import Yi.Prelude import Yi.Config-import Yi.Debug-import Yi.Undo import Yi.Buffer import Yi.Dynamic import Yi.String import Yi.Process ( popen, createSubprocess, readAvailable, SubprocessId, SubprocessInfo(..) ) import Yi.Editor-import Yi.Event (Event, prettyEvent) import Yi.Keymap+import Yi.Keymap.Keys import Yi.KillRing (krEndCmd) import qualified Yi.Interact as I import Yi.Monad-import Yi.Accessor import qualified Yi.WindowSet as WS import qualified Yi.Editor as Editor import qualified Yi.UI.Common as UI@@ -108,7 +109,7 @@ logPutStrLn "Starting Core" -- restore the old state- let initEditor = maybe (emptyEditor cfg) id st+ let initEditor = maybe emptyEditor id st -- Setting up the 1st window is a bit tricky because most functions assume there exists a "current window" newSt <- newMVar $ YiVar initEditor [] 1 M.empty (ui, runYi) <- mdo let handler exception = runYi $ (errorEditor (show exception) >> refreshEditor)@@ -121,15 +122,19 @@ runYi $ do - withEditor $ newBufferE "*messages*" (fromString "") >> return ()- when (isNothing st) $ do -- process options if booting for the first time postActions $ startActions cfg+ withEditor $ modifyA buffersA (fmap (recoverMode (modeTable cfg))) runYi refreshEditor UI.main ui -- transfer control to UI +recoverMode :: [AnyMode] -> FBuffer -> FBuffer+recoverMode tbl buffer = case fromMaybe (AnyMode emptyMode) (find (\(AnyMode m) -> modeName m == oldName) tbl) of+ AnyMode m -> setMode0 m buffer+ where oldName = case buffer of FBuffer {bmode = m} -> modeName m+ postActions :: [Action] -> YiM () postActions actions = do yi <- ask; liftIO $ output yi actions @@ -258,9 +263,6 @@ tabCount <- withEditor $ getsA tabsA WS.size when (winCount == 1 && tabCount == 1) quitEditor withEditor $ tryCloseE--reloadEditor :: YiM ()-reloadEditor = msgEditor "reloadEditor: Not supported" getAllNamesInScope :: YiM [String]
Yi/Dired.hs view
@@ -28,37 +28,29 @@ ,fnewE ) where +import Prelude (uncurry, catch)+ import qualified Data.ByteString.Lazy as LazyB-import Data.Binary-import Data.List+import Data.List hiding (find, maximum, concat) import Data.Maybe import qualified Data.Map as M-import Data.Typeable import System.Directory import System.FilePath import System.Locale import System.PosixCompat.Files import System.PosixCompat.Types import System.PosixCompat.User-import Control.Monad.Reader+import Control.Monad.Reader hiding (mapM) import System.Time import Text.Printf import Yi.Regex import Yi.MiniBuffer (withMinibufferGen, noHint)-import Control.Monad-import Control.Applicative-import Yi.Buffer-import Yi.Buffer.HighLevel import Yi.Config import Yi.Core-import Yi.Editor-import Yi.Buffer.Region import Yi.Style-import Yi.Keymap.Keys import System.FriendlyPath-import Yi.Accessor import Yi.File ------------------------------------------------ -- | If file exists, read contents of file into a new buffer, otherwise@@ -82,19 +74,27 @@ let currentBufferNames = map name bufs -- The new name for the buffer bufferName = bestNewName desiredBufferName currentBufferNames+ fDirectory = takeDirectory f+ de <- liftIO $ doesDirectoryExist f+ fe <- liftIO $ doesFileExist f+ dfe <- liftIO $ doesDirectoryExist fDirectory b <- case bufsWithThisFilename of- [] -> do- fe <- liftIO $ doesFileExist f- de <- liftIO $ doesDirectoryExist f- newBufferForPath bufferName fe de- (h:_) -> return (bkey h)+ (h:_) -> return (bkey h)+ [] -> + if de then diredDirBuffer f else do+ b <- if fe then fileToNewBuffer bufferName f else do -- Load the file into a new buffer+ when (not dfe) $ do+ userWantMkDir <- return True -- TODO+ when userWantMkDir $ liftIO $ createDirectory fDirectory+ withEditor $ stringToNewBuffer bufferName (fromString "") -- Create new empty buffer+ tbl <- asks (modeTable . yiConfig)+ case fromMaybe (AnyMode emptyMode) (find (\(AnyMode m)->modeApplies m f) tbl) of+ AnyMode newMode -> withGivenBuffer b $ setMode newMode+ return b setFileName b f- tbl <- asks (modeTable . yiConfig)- AnyMode newMode <- withBufferMode b $ \curmode -> fromMaybe (AnyMode curmode) (find (\(AnyMode m)->modeApplies m f) tbl) -- by default stick with the current mode (eg. stick with dired if -- set as such) withEditor $ switchToBufferE b- withBuffer $ setMode newMode where -- Determines whether or not a given buffer is associated with -- the given file. @@ -109,15 +109,6 @@ filename2 <- canonicalizePath f2 return $ equalFilePath filename1 filename2 - -- The first argument is the buffer name the second argument is- -- whether or not the file currently exists and the third argument- -- is whether or not the file is a directory that exists.- newBufferForPath :: String -> Bool -> Bool -> YiM BufferRef- newBufferForPath bufferName True _ =- fileToNewBuffer bufferName f -- Load the file into a new buffer- newBufferForPath _bufferName False True = diredDirBuffer f- newBufferForPath bufferName False False =- withEditor $ stringToNewBuffer bufferName (fromString "") -- Create new empty buffer -- The first argument is the buffer name@@ -158,7 +149,6 @@ } deriving (Show, Eq, Typeable) -instance Binary DiredState instance Initializable DiredState where initial = DiredState { diredPath = "" , diredMarks = M.empty@@ -198,8 +188,7 @@ setFileName b dir -- associate the buffer with the dir withEditor $ switchToBufferE b diredLoadNewDir dir- mode <- (fundamentalMode . yiConfig) <$> ask- withBuffer $ setMode mode {modeKeymap = diredKeymap}+ withBuffer $ modifyMode $ \m -> m {modeKeymap = diredKeymap, modeName = "dired"} -- Colours for Dired come from overlays not syntax highlighting return b @@ -230,7 +219,7 @@ moveTo p return () where- headStyle = const [Foreground grey]+ headStyle = const (withFg grey) doPadding :: [DRStrings] -> [String] doPadding drs = map (pad ((maximum . map drlength) drs)) drs @@ -271,12 +260,12 @@ return $ map (uncurry lineToDisplay) (M.assocs $ diredEntries dState) where lineToDisplay k (DiredFile v) = (l " -" v ++ [DRFiles k], defaultStyle, k)- lineToDisplay k (DiredDir v) = (l " d" v ++ [DRFiles k], const [Foreground blue], k)- lineToDisplay k (DiredSymLink v s) = (l " l" v ++ [DRFiles $ k ++ " -> " ++ s], const [Foreground cyan], k)- lineToDisplay k (DiredSocket v) = (l " s" v ++ [DRFiles $ k], const [Foreground magenta], k)- lineToDisplay k (DiredCharacterDevice v) = (l " c" v ++ [DRFiles $ k], const [Foreground yellow], k)- lineToDisplay k (DiredBlockDevice v) = (l " b" v ++ [DRFiles $ k], const [Foreground yellow], k)- lineToDisplay k (DiredNamedPipe v) = (l " p" v ++ [DRFiles $ k], const [Foreground brown], 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,
Yi/Dynamic.hs view
@@ -9,18 +9,22 @@ ) where +import Prelude ()+import Yi.Prelude+ import GHC.Exts import Data.Maybe import Data.Typeable-import Data.Binary-import Yi.Accessor import Data.Map as M -- --------------------------------------------------------------------- -- | Class of values that can go in the extensible state component ---class (Typeable a, Binary a) => Initializable a where+++class (Typeable a) => Initializable a where initial :: a +-- Unfortunately, this is not serializable: there is no way to recover a type from a TypeRep. data Dynamic = forall a. Initializable a => Dynamic a -- | An extensible record, indexed by type@@ -32,10 +36,10 @@ fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a fromDynamic (Dynamic b) = if typeOf (undefined :: a) == typeOf b then Just (unsafeCoerce# b) else Nothing -instance (Binary a, Typeable a) => Initializable (Maybe a) where+instance (Typeable a) => Initializable (Maybe a) where initial = Nothing --- | Accessor a dynamic component+-- | Accessor for a dynamic component dynamicValueA :: Initializable a => Accessor DynamicValues a dynamicValueA = Accessor getDynamicValue modifyDynamicValue where
Yi/Editor.hs view
@@ -7,17 +7,7 @@ module Yi.Editor where -import Yi.Buffer ( BufferRef- , FBuffer (..)- , BufferM- , newB- , runBufferFull- , insertN- , setMode)-import Yi.Buffer.Implementation (Update(..), updateIsDelete)-import Yi.Buffer.HighLevel (botB)-import Yi.Buffer.Basic-import Yi.Regex (SearchExp)+import Yi.Buffer import Yi.Config import Yi.Monad import Yi.Dynamic@@ -31,11 +21,13 @@ import Prelude (map, filter, (!!), takeWhile, length, reverse, zip) import Yi.Prelude +import Data.Binary import Data.List (nub, delete)+import Data.Foldable (concatMap) import qualified Data.DelayList as DelayList import qualified Data.Map as M import Data.Typeable-import Control.Monad.RWS+import Control.Monad.RWS hiding (get, put) import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 -- | The Editor state@@ -49,8 +41,6 @@ ,dynamic :: !(DynamicValues) -- ^ dynamic components - ,tabwidth :: !Int -- ^ width of tabs- ,statusLines :: !(DelayList.DelayList String) ,killring :: !Killring ,regex :: !(Maybe SearchExp) -- ^ most recent regex@@ -59,6 +49,10 @@ } deriving Typeable +instance Binary Editor where+ put (Editor bss bs supply ts _dv sl kr _re _dir _ev) = put bss >> put bs >> put supply >> put ts >> put sl >> put kr + get = Editor <$> get <*> get <*> get <*> get <*> pure emptyDV <*> get <*> get <*> pure Nothing <*> pure Forward <*> pure []+ windows :: Editor -> WindowSet Window windows editor = WS.current $ tabs editor@@ -118,13 +112,12 @@ -- | The initial state-emptyEditor :: Config -> Editor-emptyEditor cfg = Editor {+emptyEditor :: Editor+emptyEditor = Editor { buffers = M.singleton (bkey buf) buf ,tabs = WS.new (WS.new win) ,bufferStack = [bkey buf] ,refSupply = 2- ,tabwidth = 8 ,regex = Nothing ,searchDirection = Forward ,dynamic = M.empty@@ -132,7 +125,7 @@ ,killring = krEmpty ,pendingEvents = [] }- where buf = newB cfg 0 "*console*" (LazyUTF8.fromString "")+ where buf = newB 0 "*console*" (LazyUTF8.fromString "") win = (dummyWindow (bkey buf)) {wkey = 1, isMini = False} -- ---------------------------------------------------------------------@@ -156,11 +149,10 @@ -> LazyUTF8.ByteString -- ^ The contents with which to populate the buffer -> EditorM BufferRef stringToNewBuffer nm cs = do- cfg <- ask u <- newBufRef- b <- insertBuffer (newB cfg u nm cs)- m <- asks fundamentalMode- withGivenBuffer0 b $ setMode m+ b <- insertBuffer (newB u nm cs)+ m <- asks configFundamentalMode+ withGivenBuffer0 b $ setAnyMode m return b insertBuffer :: FBuffer -> EditorM BufferRef@@ -306,7 +298,7 @@ bs <- gets $ findBufferWithName "*messages*" b <- case bs of (b':_) -> return b'- [] -> newBufferE "*messages*" (fromString "")+ [] -> stringToNewBuffer "*messages*" (fromString "") withGivenBuffer0 b $ do botB; insertN (s ++ "\n") @@ -425,6 +417,10 @@ withWindow :: (Window -> a) -> EditorM a withWindow f = getsA (WS.currentA .> windowsA) f +findWindowWith :: WindowRef -> Editor -> Window+findWindowWith k e =+ head $ concatMap (\win -> if (wkey win == k) then [win] else []) $ windows e+ -- | Split the current window, opening a second window onto current buffer. -- TODO: unfold newWindowE here? splitE :: EditorM ()@@ -487,5 +483,4 @@ shiftOtherWindow f liftEditor prevWinE-
Yi/Eval.hs view
@@ -8,24 +8,18 @@ execEditorAction ) where -import Control.Monad import Data.Array import Data.List import Prelude hiding (error) import Yi.Regex import Yi.Config import Yi.Core hiding (toDyn)-import Yi.Keymap import Yi.Interact hiding (write) import Yi.Event-import Yi.Buffer-import Yi.Buffer.Region-import Yi.Buffer.HighLevel import Yi.Dired import Yi.Interpreter import Data.Dynamic import Control.Monad.Reader (asks)-import Yi.Editor import Yi.MiniBuffer () -- instances jumpToE :: String -> Int -> Int -> YiM ()
Yi/File.hs view
@@ -13,16 +13,9 @@ setFileName, ) where -import Control.Applicative import Control.Monad.Trans-import Prelude hiding (error)-import Yi.Accessor-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Editor (getBuffers, getBuffer, withEditor, withBuffer0)+import Prelude (filter) import Yi.Core-import Yi.Debug-import Yi.Keymap import System.Directory import System.IO.UTF8 as UTF8 import System.FilePath@@ -75,7 +68,7 @@ fwriteAllE = do buffers <- withEditor getBuffers let modifiedBuffers = filter (not . isUnchangedBuffer) buffers- mapM_ fwriteBufferE (map bkey modifiedBuffers)+ mapM_ fwriteBufferE (fmap bkey modifiedBuffers) -- | Make a backup copy of file backupE :: FilePath -> YiM ()
Yi/GHC.hs view
@@ -7,9 +7,7 @@ import Control.Monad.Reader (asks) import Control.Monad.State import Control.Monad.Writer-import Data.Binary import Data.Maybe-import Data.Typeable import ErrUtils import GHC import Outputable@@ -20,7 +18,6 @@ import Yi.Editor import Yi.Keymap import Yi.Prelude-import Yi.WindowSet (WindowSet) import qualified Data.Map as M import qualified Yi.Editor as Editor import qualified Yi.WindowSet as Robin@@ -72,7 +69,6 @@ putMVar r e' return a -instance Binary (MVar ShimState) maybeShimA :: Accessor Editor (Maybe (MVar ShimState)) maybeShimA = dynamicValueA .> dynamicA @@ -99,7 +95,7 @@ type T = (Maybe (Robin.WindowSet CompileNote)) newtype ShimNotes = ShimNotes { fromShimNotes :: T } deriving Typeable-instance Binary ShimNotes+ instance Initializable ShimNotes where initial = ShimNotes Nothing
Yi/History.hs view
@@ -7,10 +7,7 @@ module Yi.History where import Yi.Buffer-import Yi.Buffer.HighLevel (replaceBufferContent)-import Data.Binary import Data.List-import Data.Dynamic import Yi.Dynamic import Yi.Editor import qualified Data.Map as M@@ -18,7 +15,7 @@ import Prelude (maybe) type Histories = M.Map String History -instance (Binary k, Binary v, Ord k, Typeable k, Typeable v) => Initializable (M.Map k v) where+instance (Typeable k, Typeable v) => Initializable (M.Map k v) where initial = M.empty data History = History {_historyCurrent :: Int,@@ -27,7 +24,6 @@ deriving (Show, Typeable) instance Initializable History where initial = (History (-1) [])-instance Binary History dynKeyA :: (Initializable v, Ord k) => k -> Accessor (M.Map k v) v dynKeyA k = Accessor (maybe initial id . M.lookup k) (\f -> mapAlter' (upd f) k)
Yi/IncrementalParse.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE EmptyDataDecls, ScopedTypeVariables #-} -- Copyright (c) JP Bernardy 2008-{-# OPTIONS -fglasgow-exts #-} module Yi.IncrementalParse (Process, Void, recoverWith, symbol, eof, runPolish, P, AlexState (..), scanner) where
Yi/Interpreter.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE GADTs #-}-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE GADTs, ScopedTypeVariables #-} {- A mockup haskell interpreter -} module Yi.Interpreter (@@ -8,7 +7,6 @@ import Data.Dynamic import Control.Monad.Error ()-import Control.Monad (ap) import Data.Maybe import Text.ParserCombinators.Parsec.Language (haskell) import Control.Applicative
Yi/Keymap/Cua.hs view
@@ -3,17 +3,10 @@ module Yi.Keymap.Cua (keymap) where import Prelude hiding (error)-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal-import Yi.Buffer.Region import Yi.Core-import Yi.Editor import Yi.File import Yi.Keymap.Emacs.Utils-import Yi.Keymap.Keys import Yi.Misc-import Yi.Prelude keymap :: Keymap keymap = selfInsertKeymap <|> move <|> select <|> other@@ -21,7 +14,7 @@ selfInsertKeymap :: Keymap selfInsertKeymap = do c <- printableChar- write (adjBlock 1 >> withBuffer (insertB c))+ write (withBuffer0 $ replaceSel [c]) setMark :: BufferM () setMark = do@@ -33,11 +26,20 @@ unsetMark :: BufferM () unsetMark = setA highlightSelectionA False +replaceSel :: String -> BufferM ()+replaceSel s = do+ hasSel <- getA highlightSelectionA+ if hasSel+ then getSelectRegionB >>= flip replaceRegionB s+ else do+ when (length s == 1) (adjBlock 1)+ insertN s+ cut, del, copy, paste :: EditorM () cut = copy >> del del = withBuffer0 (deleteRegionB =<< getSelectRegionB) copy = setRegE =<< withBuffer0 (readRegionB =<< getSelectRegionB)-paste = withBuffer0 . insertN =<< getRegE+paste = withBuffer0 . replaceSel =<< getRegE moveKeys :: [(Event, BufferM ())] moveKeys = [@@ -59,12 +61,12 @@ move = choice [ k ?>>! unsetMark >> a | (k,a) <- moveKeys] select = choice [shift k ?>>! setMark >> a | (k,a) <- moveKeys] other = choice [- spec KBS ?>>! adjBlock (-1) >> withBuffer bdeleteB,+ spec KBS ?>>! adjBlock (-1) >> bdeleteB, spec KDel ?>>! do haveSelection <- withBuffer $ getA highlightSelectionA if haveSelection then withEditor del- else adjBlock (-1) >> withBuffer (deleteN 1),+ else withBuffer (adjBlock (-1) >> deleteN 1), spec KEnter ?>>! insertB '\n', ctrl (char 'q') ?>>! askQuitEditor, ctrl (char 'f') ?>> isearchKeymap Forward,
Yi/Keymap/Emacs.hs view
@@ -8,23 +8,15 @@ module Yi.Keymap.Emacs (keymap) where-import Control.Applicative-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal import Yi.Core import Yi.Dired-import Yi.Editor-import Yi.Keymap.Keys import Yi.File import Yi.Misc import Yi.Rectangle import Yi.TextCompletion-import Yi.Keymap.Keys import Yi.Keymap.Emacs.KillRing import Yi.Keymap.Emacs.Utils ( askQuitEditor- , adjIndent , evalRegionE , executeExtendedCommandE , findFile@@ -41,9 +33,6 @@ , askSaveEditor , argToInt )-import Yi.Accessor-import Yi.Buffer-import Yi.Buffer.Normal import Data.Maybe import Data.Char @@ -61,7 +50,7 @@ c <- printableChar when (not . except $ c) empty let n = argToInt univArg- write (adjBlock n >> withBuffer (replicateM_ n (insertB c)))+ write (adjBlock n >> replicateM_ n (insertB c)) completionKm :: Keymap@@ -77,9 +66,8 @@ setA highlightSelectionA True pointB >>= setSelectionMarkPointB -deleteB' :: YiM ()-deleteB' = do- (adjBlock (-1) >> withBuffer (deleteN 1))+deleteB' :: BufferM ()+deleteB' = adjBlock (-1) >> deleteN 1 emacsKeys :: Maybe Int -> Keymap emacsKeys univArg = @@ -89,7 +77,7 @@ , spec KEnter ?>>! (repeatingArg $ insertB '\n') , spec KDel ?>>! (repeatingArg deleteB') , spec KBS ?>>! (repeatingArg (adjBlock (-1) >> - withBuffer bdeleteB))+ bdeleteB)) , spec KHome ?>>! (repeatingArg moveToSol) , spec KEnd ?>>! (repeatingArg moveToEol) , spec KLeft ?>>! (repeatingArg leftB)
Yi/Keymap/Emacs/KillRing.hs view
@@ -4,10 +4,8 @@ module Yi.Keymap.Emacs.KillRing where -import Yi.Buffer.Region import Yi.Keymap import Yi.Buffer-import Yi.Buffer.HighLevel import Yi.Accessor import Yi.Editor import Control.Monad ( replicateM_ )
Yi/Keymap/Emacs/Utils.hs view
@@ -14,7 +14,6 @@ , askQuitEditor , askSaveEditor , modifiedQuitEditor- , adjIndent , withMinibuffer , queryReplaceE , isearchKeymap@@ -36,7 +35,6 @@ {- Standard Library Module Imports -} import Prelude ()-import Yi.Prelude import Data.List ((\\)) import System.FriendlyPath import System.FilePath (addTrailingPathSeparator)@@ -49,21 +47,15 @@ import Control.Monad (filterM, replicateM_) import Control.Monad.State (gets)-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Region import Yi.Core import Yi.Dired-import Yi.Editor import Yi.Eval import Yi.File-import Yi.Keymap.Keys import Yi.MiniBuffer import Yi.Misc import Yi.Regex import Yi.Search import Yi.Window-import Yi.Prelude {- End of Module Imports -} type UnivArgument = Maybe Int@@ -150,12 +142,6 @@ ] noAction = closeBufferAndWindowE---- | A simple wrapper to adjust the current indentation using--- the mode specific indentation function but according to the--- given indent behaviour.-adjIndent :: IndentBehaviour -> YiM ()-adjIndent ib = withSyntax (\m s -> modeIndent m s ib) ----------------------------- -- isearch
Yi/Keymap/Vim.hs view
@@ -10,36 +10,30 @@ ModeMap(..), mkKeymap) where -import Yi.Prelude import Prelude (maybe, length, filter, map, drop, break, uncurry) import Data.Char-import Data.List (sort, nub)-import Data.Dynamic+import Data.List (sort, nub, take) import Data.Prototype+import Numeric (showHex, showOct)+import System.IO (readFile) import Control.Exception ( ioErrors, try, evaluate ) import Control.Monad.State hiding (mapM_, mapM)-import Control.Applicative -import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal-import Yi.Buffer.Region-import Yi.Buffer.Indent+import {-# source #-} Yi.Boot import Yi.Core import Yi.Dired-import Yi.Editor import Yi.Eval (execEditorAction) import Yi.File import Yi.History-import Yi.Misc (matchingFileNames)+import Yi.Misc (matchingFileNames,adjBlock,adjIndent) import Yi.String (dropSpace)-import Yi.Keymap.Keys import Yi.MiniBuffer import Yi.Search import Yi.TextCompletion + -- -- What's missing? -- fancier :s//@@ -263,15 +257,15 @@ <*> pure regionStyle viMove :: ViMove -> BufferM ()- viMove NoMove = return ()- viMove (GenMove unit boundary direction) = genMoveB unit boundary direction- viMove (MaybeMove unit direction) = maybeMoveB unit direction- viMove (Move unit direction) = moveB unit direction- viMove (CharMove Forward) = moveXorEol 1- viMove (CharMove Backward) = moveXorSol 1- viMove (ArbMove move) = move- viMove (SeqMove move1 move2) = viMove move1 >> viMove move2- viMove (Replicate move i) = viReplicateMove move i+ viMove NoMove = return ()+ viMove (GenMove unit boundary dir) = genMoveB unit boundary dir+ viMove (MaybeMove unit dir) = maybeMoveB unit dir+ viMove (Move unit dir) = moveB unit dir+ viMove (CharMove Forward) = moveXorEol 1+ viMove (CharMove Backward) = moveXorSol 1+ viMove (ArbMove move) = move+ viMove (SeqMove move1 move2) = viMove move1 >> viMove move2+ viMove (Replicate move i) = viReplicateMove move i viReplicateMove :: ViMove -> Int -> BufferM () viReplicateMove (Move VLine Forward) i = lineMoveRel i >> return ()@@ -332,8 +326,8 @@ -- at word bounds: search for \<word\> searchCurrentWord :: Direction -> EditorM () searchCurrentWord dir = do- w <- withBuffer0 $ readRegionB =<< regionOfB ViWord- viSearch (Just w) [] dir+ w <- withBuffer0 $ readRegionB =<< regionOfNonEmptyB ViWord+ viSearch w [] dir -- | Parse any character that can be inserted in the text. textChar :: KeymapM Char@@ -345,11 +339,8 @@ continueSearching fdir = do m <- getRegexE dir <- fdir <$> getA searchDirectionA - let s = case m of- Nothing -> ""- Just (s',_) -> s'- printMsg $ case dir of { Forward -> '/':s ; Backward -> '?':s }- viSearch Nothing [] dir+ printMsg $ direction '?' '/' dir : maybe "" fst m+ viSearch "" [] dir -- | cmd mode commands -- An event specified paired with an action that may take an integer argument.@@ -432,6 +423,8 @@ ,(map char ">>", withBuffer . shiftIndentOfLine) ,(map char "<<", withBuffer . shiftIndentOfLine . negate) ,(map char "ZZ", const $ viWrite >> quitEditor)+ ,(map char "ga", const $ viCharInfo)+ ,(map char "==", const $ withBuffer $ adjIndent IncreaseCycle) ] -- | So-called 'operators', which take movement actions as arguments.@@ -502,14 +495,11 @@ stop <- genMoveB unit (Backward,InsideBound) Forward >> pointB return $ mkRegion start stop - select_inner_unit :: TextUnit -> BufferM Region- select_inner_unit = regionOfB- select_any_unit :: (MonadInteract m Action Event) => (Region -> EditorM ()) -> m () select_any_unit f = choice [ x | (c, unit) <- char2unit,- x <- [ char 'i' ?>> (char c ?>> write (f =<< withBuffer0 (select_inner_unit unit))),+ x <- [ char 'i' ?>> (char c ?>> write (f =<< withBuffer0 (regionOfNonEmptyB unit))), -- inner unit char 'a' ?>> (char c ?>> write (f =<< withBuffer0 (select_a_unit unit))) ] ] regionFromTo :: Point -> Point -> RegionStyle -> BufferM Region@@ -701,7 +691,7 @@ spec KRight ?>>! moveXorEol 1, spec KEnd ?>>! moveToEol, spec KHome ?>>! moveToSol,- spec KDel ?>>! deleteB Character Forward,+ spec KDel ?>>! (adjBlock (-1) >> deleteB Character Forward), spec KEnter ?>>! insertB '\n', spec KTab ?>>! insertTabB, (ctrl $ char 'w') ?>>! cut Exclusive (GenMove ViWord (Backward,InsideBound) Backward)]@@ -717,9 +707,9 @@ -- ins_char :: VimMode ins_char = v_ins_char self- def_ins_char = (spec KBS ?>>! deleteB Character Backward)+ def_ins_char = (spec KBS ?>>! adjBlock (-1) >> deleteB Character Backward) <|> ins_rep_char- <|| (textChar >>= write . insertB)+ <|| (textChar >>= write . (adjBlock 1 >>) . insertB) -- -------------------- -- | Keyword@@ -770,6 +760,9 @@ f_complete = exSimpleComplete (matchingFileNames Nothing) b_complete = exSimpleComplete matchingBufferNames ex_complete ('e':' ':f) = f_complete f+ ex_complete ('e':'d':'i':'t':' ':f) = f_complete f+ ex_complete ('r':' ':f) = f_complete f+ ex_complete ('r':'e':'a':'d':' ':f) = f_complete f ex_complete ('t':'a':'b':'e':' ':f) = f_complete f ex_complete ('b':' ':f) = b_complete f ex_complete ('b':'u':'f':'f':'e':'r':' ':f) = b_complete f@@ -789,8 +782,8 @@ ex_eval cmd = do case cmd of -- regex searching- ('/':pat) -> withEditor $ viSearch (Just pat) [] Forward- ('?':pat) -> withEditor $ viSearch (Just pat) [] Backward+ ('/':pat) -> withEditor $ viSearch pat [] Forward+ ('?':pat) -> withEditor $ viSearch pat [] Backward -- TODO: Remapping could be done using the <|| operator somehow. -- The remapped stuff could be saved in a keymap-local state, (using StateT monad transformer).@@ -863,6 +856,8 @@ fn "wqa" = wquitall fn "wqal" = wquitall fn "wqall" = wquitall+ fn "as" = viCharInfo+ fn "ascii" = viCharInfo fn "x" = do unchanged <- withBuffer isUnchangedB unless unchanged viWrite closeWindow@@ -873,10 +868,15 @@ fn "prev" = withEditor prevBufW fn ('s':'p':_) = withEditor splitE fn "e" = revertE+ fn "edit" = revertE fn ('e':' ':f) = fnewE f+ fn ('e':'d':'i':'t':' ':f) = fnewE f+ fn ('r':' ':f) = withBuffer . insertN =<< io (readFile f)+ fn ('r':'e':'a':'d':' ':f) = withBuffer . insertN =<< io (readFile f) -- fn ('s':'e':'t':' ':'f':'t':'=':ft) = withBuffer $ setSyntaxB $ highlighters M.! ft fn ('n':'e':'w':' ':f) = withEditor splitE >> fnewE f- fn ('s':'/':cs) = withEditor $ viSub cs+ fn ('s':'/':cs) = withEditor $ viSub cs Line+ fn ('%':'s':'/':cs) = withEditor $ viSub cs Document fn ('b':' ':"m") = withEditor $ switchToBufferWithNameE "*messages*" fn ('b':' ':f) = withEditor $ switchToBufferWithNameE f@@ -935,6 +935,15 @@ withAllBuffers :: YiM () -> YiM () withAllBuffers m = mapM_ (\b -> withEditor (setBuffer b) >> m) =<< readEditor bufferStack + viCharInfo :: YiM ()+ viCharInfo = do c <- withBuffer readB+ msgEditor $ showCharInfo c ""+ where showCharInfo :: Char -> String -> String+ showCharInfo c = shows c . showChar ' ' . shows d+ . showString ", Hex " . showHex d+ . showString ", Octal " . showOct d+ where d = ord c+ viFileInfo :: YiM () viFileInfo = do bufInfo <- withBuffer bufInfoB@@ -950,9 +959,9 @@ ] -- | viSearch is a doSearch wrapper that print the search outcome.-viSearch :: Maybe String -> [SearchF] -> Direction -> EditorM ()+viSearch :: String -> [SearchF] -> Direction -> EditorM () viSearch x y z = do- r <- doSearch x y z+ r <- doSearch (if null x then Nothing else Just x) y z case r of PatternFound -> return () PatternNotFound -> printMsg "Pattern not found"@@ -980,8 +989,8 @@ catchJustE ioErrors (fwriteToE f >> msg) (msgEditor . show) -- | Try to do a substitution-viSub :: String -> EditorM ()-viSub cs = do+viSub :: String -> TextUnit -> EditorM ()+viSub cs unit = do let (pat,rep') = break (== '/') cs (rep,opts) = case rep' of [] -> ([],[])@@ -989,11 +998,11 @@ (rep'', []) -> (rep'', []) (rep'', (_:fs)) -> (rep'',fs) case opts of- [] -> do_single pat rep- ['g'] -> do_single pat rep- _ -> do_single pat rep-- TODO+ [] -> do_single pat rep False+ ['g'] -> do_single pat rep True+ _ -> fail ("Trailing characters " ++ show (take 10 opts)) -- TODO more options - where do_single p r = do- s <- searchAndRepLocal p r+ where do_single p r g = do+ s <- searchAndRepUnit p r g unit if not s then fail ("Pattern not found: "++p) else msgClr
Yi/KillRing.hs view
@@ -9,14 +9,16 @@ ) where -import Yi.Buffer.Implementation (Direction(..))+import Control.Monad (ap)+import Data.Binary+import Yi.Buffer.Basic data Killring = Killring { krKilled :: Bool , krAccumulate :: Bool , krContents :: [String] , krLastYank :: Bool }- deriving (Show)+ deriving (Show {-! Binary !-}) maxDepth :: Int maxDepth = 10@@ -58,3 +60,18 @@ -- | Get the top of the killring. krGet :: Killring -> String krGet = head . krContents++++--------------------------------------------------------+-- DERIVES GENERATED CODE+-- DO NOT MODIFY BELOW THIS LINE+-- CHECKSUM: 1998721949++instance Binary Killring+ where put (Killring x1+ x2+ x3+ x4) = return () >> (put x1 >> (put x2 >> (put x3 >> put x4)))+ get = case 0 of+ 0 -> ap (ap (ap (ap (return Killring) get) get) get) get
Yi/Lexer/Alex.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -fglasgow-exts #-} module Yi.Lexer.Alex ( alexGetChar, alexInputPrevChar, unfoldLexer, lexScanner,@@ -93,7 +92,7 @@ actionConst token _str state = (state, token) actionAndModify :: (lexState -> lexState) -> token -> Action lexState token-actionAndModify modifier token _str state = (modifier state, token)+actionAndModify modifierFct token _str state = (modifierFct state, token) actionStringConst :: (String -> token) -> Action lexState token actionStringConst f indexedStr state = (state, f $ fmap snd indexedStr)
Yi/Lexer/Haskell.x view
@@ -41,7 +41,7 @@ @reservedid = as|case|class|data|default|else|hiding|if| import|in|infix|infixl|infixr|instance|newtype|- qualified|then|type|forall|foreign|export|dynamic|+ qualified|then|type|family|forall|foreign|export|dynamic| safe|threadsafe|unsafe|stdcall|ccall|dotnet @layoutReservedId =@@ -156,10 +156,10 @@ tokenToStyle :: Token -> StyleName tokenToStyle tok = case tok of CppDirective -> preprocessorStyle- Number -> defaultStyle+ Number -> numberStyle CharTok -> stringStyle StringTok -> stringStyle- VarIdent -> defaultStyle+ VarIdent -> variableStyle ConsIdent -> typeStyle ReservedOp _ -> operatorStyle Reserved _ -> keywordStyle
Yi/Lexer/Latex.x view
@@ -14,12 +14,13 @@ import Yi.Style } -$whitechar = [\ \t\n\r\f\v]-$special = [\[\]\{\}\$\\\%]-$idchar = [^ $special $whitechar]+$special = [\[\]\{\}\$\\\%\(\)\ ]+$textChar = [~$special $white]+$idchar = [a-zA-Z 0-9_\-] @reservedid = begin|end|newcommand @ident = $idchar++@text = $textChar+ haskell :- @@ -30,8 +31,7 @@ \\$special { cs $ \(_:cs) -> Command cs } \\newcommand { c $ NewCommand } \\@ident { cs $ \(_:cs) -> Command cs }- @ident { c $ Text }- $white+ ; + @text { c $ Text } {
Yi/Lexer/LiterateHaskell.x view
@@ -41,7 +41,7 @@ @reservedid = as|case|class|data|default|deriving|do|else|hiding|if| import|in|infix|infixl|infixr|instance|let|module|newtype|- of|qualified|then|type|where|forall|mdo|foreign|export|dynamic|+ of|qualified|then|type|where|family|forall|mdo|foreign|export|dynamic| safe|threadsafe|unsafe|stdcall|ccall|dotnet @reservedop =
Yi/Lexer/Perl.x view
@@ -145,7 +145,7 @@ ^ @reservedId / @seperator { c keywordStyle } @varTypeOp- { m (\s -> HlInVariable 0 s) (defaultStyle `withFg` darkcyan) }+ { m (\s -> HlInVariable 0 s) (const $ withFg darkcyan) } @reservedop { c operatorStyle } @@ -262,7 +262,7 @@ } @varTypeOp- { m (\s -> HlInVariable 0 s) (defaultStyle `withFg` darkcyan) }+ { m (\s -> HlInVariable 0 s) (const $ withFg darkcyan) } ./ {@@ -298,7 +298,7 @@ } $white+ { c defaultStyle } @varTypeOp- { m (\s -> HlInVariable 0 s) (defaultStyle `withFg` darkcyan) }+ { m (\s -> HlInVariable 0 s) (const $ withFg darkcyan) } . { c stringStyle } } @@ -307,15 +307,15 @@ -- Support highlighting uses of the # to determine subscript of the last element. -- This isn't entirely correct as it'll accept $########foo. (@varTypeOp | "#")- { c $ defaultStyle `withFg` darkcyan }+ { c $ const (withFg darkcyan) } "{"- { m increaseVarCastDepth $ defaultStyle `withFg` darkcyan}+ { m increaseVarCastDepth $ const (withFg darkcyan) } "}"- { m decreaseVarCastDepth $ defaultStyle `withFg` darkcyan}+ { m decreaseVarCastDepth $ const (withFg darkcyan) } @specialVarIdentifier- { m exitVarIfZeroDepth $ defaultStyle `withFg` cyan }+ { m exitVarIfZeroDepth $ const (withFg cyan) } @varIdentifier- { m exitVarIfZeroDepth $ defaultStyle `withFg` darkcyan }+ { m exitVarIfZeroDepth $ const (withFg darkcyan) } $white { m (\(HlInVariable _ s) -> s) defaultStyle } .
Yi/Main.hs view
@@ -1,48 +1,27 @@- -- Copyright (c) Tuomo Valkonen 2004. -- Copyright (c) Don Stewart 2004-5. -- Copyright (c) Jean-Philippe Bernardy 2006,2007.------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2 of the License, or--- (at your option) any later version.--- ------ | This is the real main module of Yi, and is shared between--- Main.hs (the static binary), and dynamically loaded by Boot.hs.--- We take any config arguments from the boot loader (if that is how we--- are being invoked) parse command line args, initialise the ui, before--- jumping into an event loop.---+-- | This is the main module of Yi, called with configuration from the user.+-- Here we mainly process command line arguments. module Yi.Main (main, defaultConfig, projectName) where import Prelude ()-import Yi.Prelude import qualified Yi.Keymap.Emacs as Emacs import qualified Yi.Keymap.Vim as Vim import qualified Yi.Keymap.Cua as Cua import Yi.Modes import qualified Yi.Mode.Haskell as Haskell-import Yi.Buffer hiding (file)-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal-import Yi.Buffer.Region+import {-# source #-} Yi.Boot import Yi.Config-import Yi.Core-import Yi.Debug+import Yi.Core hiding (file) import Yi.Dired-import Yi.Editor-import Yi.Keymap.Keys import Yi.File import Yi.Misc import Yi.Style.Library import Data.Dynamic-import Data.Prototype import Yi.Keymap.Emacs.Utils-import Yi.Keymap.Keys import HConf (hconfOptions) import Paths_yi import Distribution.Text (display)@@ -204,15 +183,10 @@ AnyMode srmcMode, AnyMode ocamlMode, AnyMode perlMode,- AnyMode pythonMode]- , fundamentalMode = fundamental+ AnyMode pythonMode,+ AnyMode fundamentalMode] , debugMode = False , configKillringAccumulate = False- , configIndentSettings = IndentSettings - {expandTabs = True- ,tabSize = 8- ,shiftWidth = 4- } } -- | List of published Actions@@ -249,6 +223,7 @@ , ("regionOfB" , box regionOfB) , ("regionOfPartB" , box regionOfPartB) , ("regionOfPartNonEmptyB" , box regionOfPartNonEmptyB)+ , ("reloadEditor" , box reloadEditor) , ("reloadProjectE" , box reloadProjectE) , ("revertE" , box revertE) , ("shell" , box shell)@@ -301,8 +276,8 @@ -- application, and the real front end, in a sense. 'dynamic_main' calls -- this after setting preferences passed from the boot loader. ---main :: Config -> IO ()-main cfg = do+main :: Config -> Maybe Editor -> IO ()+main cfg state = do #ifdef FRONTEND_COCOA withAutoreleasePool $ do #endif@@ -315,4 +290,4 @@ Left (Err err code) -> do putStrLn err exitWith code Right finalCfg -> do when (debugMode finalCfg) $ initDebug ".yi.dbg" - startEditor finalCfg Nothing+ startEditor finalCfg state
Yi/MiniBuffer.hs view
@@ -8,21 +8,14 @@ matchingBufferNames ) where -import Control.Applicative-import Data.List (isInfixOf, find)-import Data.Typeable+import Prelude (filter)+import Data.List (isInfixOf) import Data.Maybe-import Yi.Buffer-import Yi.Buffer.Region-import Yi.Buffer.HighLevel import Yi.Config import Yi.Core-import Yi.Editor import Yi.History import Yi.Completion (commonPrefix, infixMatch, prefixMatch, completeInList)-import Yi.Keymap-import Yi.Keymap.Keys-import qualified Yi.Editor as Editor+import qualified Yi.Core as Editor import qualified Yi.WindowSet as WS import Control.Monad.Reader @@ -33,8 +26,7 @@ spawnMinibufferE :: String -> KeymapEndo -> EditorM BufferRef spawnMinibufferE prompt kmMod = do b <- stringToNewBuffer prompt (fromString "")- fundamental <- asks fundamentalMode- withGivenBuffer0 b $ setMode (fundamental {modeKeymap = kmMod})+ withGivenBuffer0 b $ modifyMode (\m -> m {modeKeymap = kmMod}) w <- newWindowE True b modifyWindows (WS.add w) return b@@ -176,7 +168,7 @@ matchingBufferNames :: String -> YiM [String] matchingBufferNames _s = withEditor $ do bs <- getBuffers- return (map name bs)+ return (fmap name bs) -- TODO: be a bit more clever than 'Read r'
Yi/Misc.hs view
@@ -30,13 +30,9 @@ {- External Library Module Imports -} {- Local (yi) module imports -} -import Data.Typeable import Prelude (words)-import Yi.Prelude import Yi.Monad-import Yi.Buffer import Yi.Core-import Yi.Editor import Yi.MiniBuffer import qualified Yi.Mode.Compilation as Compilation import Yi.Process@@ -174,6 +170,12 @@ (sDir, files) <- getAppropriateFiles start s return $ fmap (sDir </>) files -adjBlock :: Int -> YiM ()-adjBlock x = withSyntax (\m s -> modeAdjustBlock m s x)+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)
Yi/Mode/Compilation.hs view
@@ -1,19 +1,14 @@ module Yi.Mode.Compilation where import Prelude ()-import Yi.Buffer import Yi.Core import Yi.Lexer.Alex (Tok(..), Posn(..))-import Yi.Prelude import Yi.Style import Yi.Syntax import Yi.Dired-import Yi.Editor-import Yi.Keymap import qualified Yi.Lexer.Alex as Alex import qualified Yi.Lexer.Compilation as Compilation import qualified Yi.Syntax.Linear as Linear-import Yi.Keymap.Keys mode :: Mode (Linear.Result (Tok Compilation.Token)) mode = emptyMode
Yi/Mode/Haskell.hs view
@@ -20,18 +20,9 @@ import Data.Binary import Data.List (isPrefixOf, dropWhile, takeWhile, filter, drop) import Data.Maybe (maybe, listToMaybe, isJust)-import Data.Typeable import Prelude (unwords)-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Indent-import Yi.Buffer.Normal-import Yi.Buffer.Region import Yi.Core-import Yi.Dynamic-import Yi.Editor import Yi.File-import Yi.Keymap import Yi.Lexer.Alex (Tok(..),Posn(..),tokBegin,tokEnd,tokRegion) import Yi.Lexer.Haskell (Token(..), ReservedType(..), startsLayout) import Yi.Prelude@@ -82,7 +73,7 @@ } -- | "Clever" hasell mode, using the --- preciseMode :: Mode [Hask.Tree TT]+preciseMode :: Mode (Hask.Tree TT) preciseMode = emptyMode { modeName = "precise haskell",@@ -189,6 +180,7 @@ tokText :: Tok t -> BufferM String tokText = readRegionB . tokRegion +isLineComment :: TT -> Bool isLineComment = (Just Haskell.Line ==) . tokTyp . tokT contiguous :: forall t. Tok t -> Tok t -> Bool@@ -252,7 +244,7 @@ haskellToggleCommentSelectionB :: BufferM () haskellToggleCommentSelectionB = do- l <- readUnitB Yi.Buffer.Normal.Line+ l <- readUnitB Yi.Core.Line if ("--" `isPrefixOf` l) then haskellUnCommentSelectionB else haskellCommentSelectionB
Yi/Mode/Interactive.hs view
@@ -1,15 +1,7 @@ module Yi.Mode.Interactive where import Prelude ()-import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Region import Yi.Core-import Yi.Core-import Yi.Editor-import Yi.Keymap-import Yi.Keymap.Keys-import Yi.Prelude import Yi.Region import Yi.Lexer.Alex (Tok(..)) import Yi.History
Yi/Mode/Shim.hs view
@@ -75,7 +75,7 @@ minorMode m = m { modeName = modeName m ++ "+shim",- modeKeymap = (<||) + modeKeymap = modeKeymap m . ((<||) (((ctrl $ char 'c') ?>> choice [ctrl (char 't') ?>>! typeAtPos, char '!' ?>> char 't' ?>>! annotType,@@ -90,6 +90,6 @@ runShimThread (Hsinfo.load filename True Nothing >> return ()) return () ]- ) <|> (ctrl (char 'x') ?>> char '`' ?>>! jumpToNextNote))+ ) <|> (ctrl (char 'x') ?>> char '`' ?>>! jumpToNextNote))) }
Yi/Modes.hs view
@@ -1,4 +1,4 @@-module Yi.Modes (fundamental,+module Yi.Modes (fundamentalMode, latexMode, cppMode, literateHaskellMode, cabalMode, srmcMode, ocamlMode, perlMode, pythonMode, latexMode2, anyExtension@@ -7,9 +7,7 @@ import Control.Arrow (first) import Prelude () import System.FilePath-import Yi.Buffer (Mode(..), emptyMode)-import Yi.Buffer.HighLevel (fillParagraph)-import Yi.Buffer.Indent+import Yi.Buffer import Yi.Lexer.Alex (Tok(..), Posn(..)) import Yi.Prelude import Yi.Style@@ -28,10 +26,10 @@ import qualified Yi.Syntax.Latex as Latex -fundamental :: Mode syntax+fundamentalMode :: Mode syntax latexMode, cppMode, literateHaskellMode, cabalMode, srmcMode, ocamlMode, perlMode, pythonMode :: Mode (Linear.Result Stroke) -fundamental = emptyMode+fundamentalMode = emptyMode { modeName = "fundamental", modeApplies = const True,@@ -53,7 +51,7 @@ mkHighlighter' initSt scan tokenToStyle = mkHighlighter (Linear.incrScanner . Alex.lexScanner (fmap (first tokenToStroke) . scan) initSt) Linear.getStrokes where tokenToStroke (Tok t len posn) = (posnOfs posn, tokenToStyle t, posnOfs posn +~ len) -cppMode = fundamental+cppMode = fundamentalMode { modeApplies = anyExtension ["cxx", "cpp", "C", "hxx", "H", "h", "c"], -- Treat c file as cpp files, most users will allow for that.@@ -61,14 +59,14 @@ modeHL = ExtHL $ mkHighlighter' Cplusplus.initState Cplusplus.alexScanToken id } -literateHaskellMode = fundamental+literateHaskellMode = fundamentalMode { modeName = "literate haskell", modeApplies = anyExtension ["lhs"], modeHL = ExtHL $ mkHighlighter' LiterateHaskell.initState LiterateHaskell.alexScanToken id } -cabalMode = fundamental+cabalMode = fundamentalMode { modeName = "cabal", modeApplies = anyExtension ["cabal"],@@ -77,7 +75,7 @@ latexLexer = Alex.lexScanner Latex.alexScanToken Latex.initState -latexMode = fundamental+latexMode = fundamentalMode { modeName = "plain latex", modeApplies = anyExtension ["tex", "sty", "ltx"],@@ -85,7 +83,7 @@ } latexMode2 :: Mode [Latex.Tree Latex.TT]-latexMode2 = fundamental+latexMode2 = fundamentalMode { modeApplies = modeApplies latexMode, modeName = "latex",@@ -94,7 +92,7 @@ (\point begin end t -> Latex.getStrokes point begin end t) } -srmcMode = fundamental+srmcMode = fundamentalMode { modeName = "srmc", modeApplies = anyExtension ["pepa", -- pepa is a subset of srmc @@ -102,25 +100,26 @@ modeHL = ExtHL $ mkHighlighter' Srmc.initState Srmc.alexScanToken id } -ocamlMode = fundamental+ocamlMode = fundamentalMode { modeName = "ocaml", modeApplies = anyExtension ["ml", "mli", "mly", "mll", "ml4", "mlp4"], modeHL = ExtHL $ mkHighlighter' OCaml.initState OCaml.alexScanToken OCaml.tokenToStyle } -perlMode = fundamental+perlMode = fundamentalMode { modeName = "perl", modeApplies = anyExtension ["pl", "pm"], modeHL = ExtHL $ mkHighlighter' Perl.initState Perl.alexScanToken id } -pythonMode = fundamental+pythonMode = fundamentalMode { modeName = "python", modeApplies = anyExtension ["t", "py"], modeHL = ExtHL $ mkHighlighter' Python.initState Python.alexScanToken id } +anyExtension :: [String] -> FilePath -> Bool anyExtension list fileName = or [takeExtension fileName == ('.' : ext) | ext <- list]
Yi/Process.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-} -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons module Yi.Process (popen, runShellCommand, shellFileName, createSubprocess, readAvailable, SubprocessInfo(..), SubprocessId) where
Yi/Rectangle.hs view
@@ -9,9 +9,6 @@ import Data.List (sort) import Yi.Buffer-import Yi.Buffer.HighLevel-import Yi.Buffer.Normal-import Yi.Buffer.Region import Yi.Editor import Yi.String
Yi/Region.hs view
@@ -7,12 +7,13 @@ ( Region , emptyRegion- , mkRegion, mkRegion'+ , mkRegion, mkRegion', mkSizeRegion , regionStart , regionEnd , regionSize , regionDirection , inRegion, nearRegion+ , includedRegion , fmapRegion , intersectRegion , unionRegion@@ -66,6 +67,9 @@ mkRegion' :: Direction -> Point -> Point -> Region mkRegion' d x y = if x <= y then Region d x y else Region d y x +mkSizeRegion :: Point -> Size -> Region+mkSizeRegion x s = mkRegion x (x +~ s)+ -- | The empty region emptyRegion :: Region emptyRegion = Region Forward 0 0 @@ -78,6 +82,7 @@ nearRegion :: Point -> Region -> Bool p `nearRegion` (Region _ start stop) = start <= p && p <= stop -+includedRegion :: Region -> Region -> Bool+(Region _ start stop) `includedRegion` r = start `inRegion` r && stop `inRegion` r
Yi/Search.hs view
@@ -12,7 +12,8 @@ SearchMatch, SearchResult(..), SearchF(..),- searchAndRepLocal, -- :: String -> String -> IO Bool+ searchAndRepRegion, -- :: String -> String -> Bool -> Region -> EditorM Bool+ searchAndRepUnit, -- :: String -> String -> Bool -> TextUnit -> EditorM Bool doSearch, -- :: (Maybe String) -> [SearchF] -- -> Direction -> YiM () searchInit, -- :: String@@ -41,26 +42,16 @@ qrFinish, ) where -import Data.Binary import Prelude ()-import Yi.Prelude-import Yi.Buffer-import Yi.Buffer.Normal-import Yi.Buffer.HighLevel import Yi.Regex-import Yi.Buffer.Region-import Yi.Editor-import qualified Yi.Editor as Editor import Yi.Window import Data.Char import Data.Maybe import Data.Either-import Data.List (span, takeWhile)-import Data.Typeable--import Control.Monad.State+import Data.List (span, takeWhile, take, filter) import Yi.Core+import Yi.Core as Editor import Yi.History -- ---------------------------------------------------------------------@@ -141,30 +132,31 @@ --------------------------------------------------------------------------- | Search and replace /on current line/. Returns Bool indicating--- success or failure--- TODO: simplify-searchAndRepLocal :: String -> String -> EditorM Bool-searchAndRepLocal [] _ = return False -- hmm...-searchAndRepLocal re str = do+-- | Search and replace in the given region.+-- If the input boolean is True, then the replace is done globally.+-- Returns Bool indicating success or failure.+searchAndRepRegion :: String -> String -> Bool -> Region -> EditorM Bool+searchAndRepRegion [] _ _ _ = return False -- hmm...+searchAndRepRegion re str globally region = do let Just c_re = makeSearchOptsM [] re setRegexE c_re -- store away for later use setA searchDirectionA Forward- mp <- withBuffer0 $ regexB Forward c_re -- find the regex- case mp of- (r:_) -> withBuffer0 $ savingPointB $ do- moveToEol- ep <- pointB -- eol point of current line- moveTo $ regionStart r- moveToEol- eq <- pointB -- eol of matched line- if (ep /= eq) -- then match isn't on current line- then return False- else do -- do the replacement- replaceRegionB r str- return True -- signal success- [] -> return False+ mp <- withBuffer0 $+ (if globally then id else take 1) <$>+ filter (`includedRegion` region) <$>+ 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+ withBuffer0 $ mapM_ (`replaceRegionB` str) mp'+ return (not $ null mp) +------------------------------------------------------------------------+-- | Search and replace in the region defined by the given unit.+-- The rest is as in 'searchAndRepRegion'.+searchAndRepUnit :: String -> String -> Bool -> TextUnit -> EditorM Bool+searchAndRepUnit re str g unit = searchAndRepRegion re str g =<< (withBuffer0 $ regionOfB unit) -------------------------- -- Incremental search@@ -174,9 +166,9 @@ -- This contains: (string currently searched, position where we -- searched it, direction, overlay for highlighting searched text) --- TODO: Maybe this should not be saved in a Dynamic component!--- it could also be embedded in the Keymap state.-instance Binary Isearch+-- Note that this info cannot be embedded in the Keymap state: the state+-- modification can depend on the state of the editor.+ instance Initializable Isearch where initial = (Isearch []) @@ -274,6 +266,7 @@ (p:_) -> do withBuffer0 $ do moveTo (regionEnd p)+ printMsg $ "I-search: " ++ current setDynamic $ Isearch ((current,p,direction):rest) where startOfs = case direction of Forward -> 1
Yi/Style.hs view
@@ -5,60 +5,67 @@ import Data.Word (Word8) import Data.Char (chr, ord)-import Data.Maybe+import Data.Monoid import Yi.Prelude import Prelude () +-- | Visual text attributes to be applied during layout.+data Attributes = Attributes+ { foreground :: !Color+ , background :: !Color+ } deriving (Eq, Ord, Show)++-- | The style is used to transform attributes by modifying+-- one or more of the visual text attributes.+type Style = Endo Attributes+ -- | The UI type-data UIStyle =- UIStyle {- window :: Style -- ^ window fg and bg- , modeline :: Style -- ^ out of focus modeline colours- , modelineFocused :: Style -- ^ in focus modeline- , selected :: Style -- ^ the selected portion- , eof :: Style -- ^ empty file marker colours- , defaultStyle :: Style- , reverseStyle :: Style- , preprocessorStyle :: Style -- ^ preprocessor directive (often in Haskell or C)- , commentStyle :: Style- , blockCommentStyle :: Style- , keywordStyle :: Style+data UIStyle = UIStyle+ { modelineAttributes :: Attributes -- ^ ground attributes for the modeline+ , modelineFocusStyle :: Style -- ^ transformation of modeline in focus - , operatorStyle :: Style+ , baseAttributes :: Attributes -- ^ ground attributes for the main text views - , variableStyle :: Style -- ^ any standard variable (identifier)- , typeStyle :: Style -- ^ class (in an OO language) or a Haskell type+ -- General styles applied to the ground attributes above+ , selectedStyle :: Style -- ^ the selected portion+ , eofStyle :: Style -- ^ empty file marker colours - , stringStyle :: Style- , longStringStyle :: Style- , numberStyle :: Style+ , errorStyle :: Style -- ^ indicates errors in text+ , hintStyle :: Style -- ^ search matches+ , strongHintStyle :: Style -- ^ TODO: what is this? - , errorStyle :: Style- , hintStyle :: Style- , strongHintStyle :: Style- } - deriving (Eq, Show, Ord)+ -- Syntaxt highlighting styles+ , commentStyle :: Style -- ^ all comments+ , blockCommentStyle :: Style -- ^ additional only for block comments+ , keywordStyle :: Style -- ^ applied to language keywords+ , numberStyle :: Style -- ^ numbers+ , preprocessorStyle :: Style -- ^ preprocessor directive (often in Haskell or C)+ , stringStyle :: Style -- ^ constant strings+ , longStringStyle :: Style -- ^ additional style for long strings+ , typeStyle :: Style -- ^ type name (such as class in an OO language)+ , variableStyle :: Style -- ^ any standard variable (identifier)+ , operatorStyle :: Style -- ^ infix operators+ }+-- deriving (Eq, Show) type StyleName = UIStyle -> Style +withFg, withBg :: Color -> Style+-- | A style that sets the foreground.+withFg c = Endo $ \s -> s { foreground = c }+-- | A style that sets the background.+withBg c = Endo $ \s -> s { background = c }++-- | The identity transform.+defaultStyle :: StyleName+defaultStyle = mempty+ data Color = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 | Default | Reverse deriving (Eq,Ord,Show) -data Attr = Foreground !Color - | Background !Color- deriving (Eq, Show, Ord)--type Style = [Attr]--background :: Style -> Color-background s = fromMaybe Default $ listToMaybe [c | Background c <- s]--foreground :: Style -> Color-foreground s = fromMaybe Default $ listToMaybe [c | Foreground c <- s]- -- | Convert a color to its text specification, as to be accepted by XParseColor colorToText :: Color -> String colorToText Default = "default"@@ -92,23 +99,3 @@ white = RGB 165 165 165 brightwhite = RGB 255 255 255 ---- TODO: These are so close in syntax I must imagine there is a way to simplify--- them - Corey O'C.-withFg :: StyleName -> Color -> UIStyle -> Style-withFg baseStyleName color = addOrChangeFg color . baseStyleName--addOrChangeFg color [] = [Foreground color]-addOrChangeFg color (Foreground _ : attrs) = (Foreground color) : attrs-addOrChangeFg color (a : attrs) = a : (addOrChangeFg color attrs)--withBg :: StyleName -> Color -> UIStyle -> Style-withBg baseStyleName color = addOrChangeBg color . baseStyleName--addOrChangeBg color [] = [Background color]-addOrChangeBg color (Background _ : attrs) = (Background color) : attrs-addOrChangeBg color (a : attrs) = a : (addOrChangeBg color attrs)---changeFg = flip addOrChangeFg-changeBg = flip addOrChangeBg
Yi/Style/Library.hs view
@@ -2,68 +2,59 @@ module Yi.Style.Library where import Yi.Style import Data.Prototype+import Data.Monoid type Theme = Proto UIStyle -- | Abstract theme that provides useful defaults. defaultTheme :: Theme-defaultTheme = Proto $ \self -> UIStyle- { window = defaultStyle self- , modeline = error "modeline must be redefined!"- , modelineFocused = modeline self `changeFg` brightwhite- , selected = reverseStyle self- , eof = [Foreground blue]- , defaultStyle = error "defaultStyle must be redefined!"- , reverseStyle = [Foreground Reverse, Background Reverse]- , preprocessorStyle = defaultStyle self `changeFg` red- , commentStyle = defaultStyle self `changeFg` purple- , blockCommentStyle = commentStyle self- , keywordStyle = defaultStyle self `changeFg` darkblue-- , operatorStyle = defaultStyle self `changeFg` brown+defaultTheme = Proto $ const $ UIStyle+ { modelineAttributes = error "modeline must be redefined!"+ , modelineFocusStyle = withFg brightwhite - , variableStyle = defaultStyle self- , typeStyle = variableStyle self `changeFg` darkgreen+ , baseAttributes = error "window must be redefined!" - , stringStyle = defaultStyle self `changeFg` darkcyan- , longStringStyle = stringStyle self- , numberStyle = defaultStyle self `changeFg` darkred+ , selectedStyle = withFg Reverse `mappend` withBg Reverse+ , eofStyle = withFg blue+ , errorStyle = withBg red+ , hintStyle = withBg cyan+ , strongHintStyle = withBg magenta - , errorStyle = defaultStyle self `changeBg` red- , hintStyle = defaultStyle self `changeBg` cyan- , strongHintStyle = defaultStyle self `changeBg` magenta- }+ , commentStyle = withFg purple+ , blockCommentStyle = mempty+ , keywordStyle = withFg darkblue+ , numberStyle = withFg darkred+ , preprocessorStyle = withFg red+ , stringStyle = withFg darkcyan+ , longStringStyle = mempty+ , typeStyle = withFg darkgreen+ , variableStyle = mempty+ , operatorStyle = withFg brown+ } -- | The default UIStyle defaultLightTheme :: Theme defaultLightTheme = defaultTheme `override` \super _ -> super- { modeline = [Foreground black, Background darkcyan]- , defaultStyle = []- }+ { modelineAttributes = Attributes { foreground = black, background = darkcyan }+ , baseAttributes = Attributes { foreground = Default, background = Default }+ } -- | A UIStyle inspired by the darkblue colorscheme of Vim. darkBlueTheme :: Theme darkBlueTheme = defaultTheme `override` \super _ -> super- {- window = [Background black, Foreground white]- , modeline = [Background white, Foreground darkblue]- , modelineFocused = [Background white, Foreground darkblue]- , selected = [Background blue, Foreground white]- , eof = [Background black, Foreground red]- , defaultStyle = [Background black, Foreground white]+ { modelineAttributes = Attributes { foreground = darkblue, background = white }+ , modelineFocusStyle = withBg brightwhite - , reverseStyle = [Foreground green]- , preprocessorStyle = [Foreground red]- , commentStyle = [Foreground darkred]- , keywordStyle = [Foreground brown]- , operatorStyle = [Foreground white]- , typeStyle = [Foreground darkgreen]- , stringStyle = [Foreground purple]- , numberStyle = [Foreground darkred]- , errorStyle = [Foreground green]+ , baseAttributes = Attributes { foreground = white, background = black } - , hintStyle = [Background darkblue]- , strongHintStyle = [Background blue]- }+ , selectedStyle = withFg white `mappend` withBg blue+ , eofStyle = withFg red+ , hintStyle = withBg darkblue+ , strongHintStyle = withBg blue + , commentStyle = withFg darkred+ , keywordStyle = withFg brown+ , stringStyle = withFg purple+ , operatorStyle = withFg white+ }
Yi/Syntax/Fractal.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -fglasgow-exts #-} module Yi.Syntax.Fractal (parse, getStrokes) where import Yi.Lexer.Alex (Tok(..), tokBegin)
Yi/Syntax/Latex.hs view
@@ -4,7 +4,7 @@ import Yi.IncrementalParse import Yi.Lexer.Alex import Yi.Lexer.Latex-import Yi.Style hiding (eof)+import Yi.Style import Yi.Syntax.Tree import Yi.Syntax import Yi.Prelude @@ -17,6 +17,7 @@ isNoise Comment = True isNoise (Command _) = True isNoise NewCommand = True+isNoise (Special ' ') = True isNoise (Special _) = False isNoise (Begin _) = False isNoise (End _) = False@@ -122,7 +123,7 @@ case t of Comment -> commentStyle Text -> defaultStyle- Special _ -> operatorStyle+ Special _ -> defaultStyle Command _ -> typeStyle Begin _ -> keywordStyle End _ -> keywordStyle
Yi/Syntax/Layout.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-} module Yi.Syntax.Layout (layoutHandler, State) where import Yi.Syntax
Yi/TextCompletion.hs view
@@ -10,18 +10,11 @@ ) where import Prelude ()-import Yi.Prelude import Yi.Completion-import Yi.Buffer-import Data.Binary import Data.Char-import Data.Typeable import Data.List (filter, drop, isPrefixOf, reverse, findIndex, length, groupBy) import Data.Maybe -import Yi.Buffer.Normal-import Yi.Buffer.Region-import Yi.Editor import Yi.Core -- ---------------------------------------------------------------------@@ -37,7 +30,7 @@ -- (this seems very inefficient; but we use lazyness to our advantage) deriving Typeable -instance Binary Completion+-- TODO: put this in keymap state instead instance Initializable Completion where initial = Completion []
Yi/UI/Cocoa.hs view
@@ -32,12 +32,13 @@ import qualified Data.List as L import Data.IORef import Data.Maybe+import Data.Monoid import Data.Unique import qualified Data.Map as M import Foundation hiding (name, new, parent, error, self, null) -import AppKit hiding (windows, start, rect, width, content, prompt, dictionary, icon, concat, remove, insert, update)+import AppKit hiding (windows, start, rect, width, content, prompt, dictionary, icon, concat, remove, insert, update, convertAttributes) import qualified AppKit.NSWindow import qualified AppKit.NSView @@ -68,14 +69,11 @@ } mkUI :: UI -> Common.UI-mkUI ui = Common.UI- {- Common.main = main,- Common.end = end,- Common.suspend = uiWindow ui # performMiniaturize nil,- Common.refresh = refresh ui,- Common.prepareAction = return (return ()),- Common.reloadProject = \_ -> return ()+mkUI ui = Common.dummyUI+ { Common.main = main+ , Common.end = end+ , Common.suspend = uiWindow ui # performMiniaturize nil+ , Common.refresh = refresh ui } rect :: Float -> Float -> Float -> Float -> NSRect@@ -201,7 +199,7 @@ let ui = UI win winContainer cmd bufs wc (outCh . singleton) (configUI cfg) - cmd # setColors ui Style.window+ cmd # setColors (Style.baseAttributes $ configStyle $ uiConfig ui) return (mkUI ui) @@ -234,9 +232,8 @@ (textview i) # AppKit.NSView.window >>= makeFirstResponder (textview i) return (i{window = w}) -setColors :: (Has_setBackgroundColor t, Has_setTextColor t) => UI -> Style.StyleName -> t -> IO ()-setColors ui styleName slf = do- let s = styleName $ configStyle $ uiConfig ui+setColors :: (Has_setBackgroundColor t, Has_setTextColor t) => Style.Attributes -> t -> IO ()+setColors s slf = do getColor True (Style.foreground s) >>= flip setTextColor slf getColor False (Style.background s) >>= flip setBackgroundColor slf @@ -248,9 +245,11 @@ v # setSelectable True v # setAlignment nsLeftTextAlignment v # sizeToFit- attrs <- convertStyle $ Style.selected $ configStyle $ uiConfig ui+ let sty = configStyle $ uiConfig ui+ ground = Style.baseAttributes sty+ attrs <- convertAttributes $ appEndo (Style.selectedStyle sty) $ ground v # setSelectedTextAttributes attrs- v # setColors ui Style.window+ v # setColors ground v # textColor >>= flip setInsertionPointColor v (ml, view) <- if (isMini win)@@ -262,7 +261,7 @@ prompt # sizeToFit prompt # setAutoresizingMask nsViewNotSizable prompt # setBordered False- prompt # setColors ui Style.window+ prompt # setColors ground prect <- prompt # frame vrect <- v # frame@@ -301,7 +300,8 @@ scroll # setIVar _leftScroller (configLeftSideScrollBar $ uiConfig ui) addSubviewWithTextLine scroll (uiBox ui) - ml # setColors ui Style.modeline+ -- TODO: Support focused modeline...+ ml # setColors (Style.modelineAttributes sty) storage <- getTextStorage ui b layoutManager v >>= replaceTextStorage storage @@ -344,10 +344,6 @@ let (p,l) = if showSel then (min p0 p1, abs $ p1~-p0) else (p0,0) (textview w) # setSelectedRange (NSRange (fromIntegral p) (fromIntegral l)) (textview w) # scrollRangeToVisible (NSRange (fromIntegral p0) 0)- -- Signal to Cocoa that we need to update attributes in the visible range...- storage <- castObject <$> (textview w) # textStorage- visRange <- (textview w) # visibleRange- storage # visibleRangeChanged visRange (modeline w) # setStringValue (toNSString txt) getTextStorage :: UI -> FBuffer -> IO TextStorage
Yi/UI/Cocoa/TextStorage.hs view
@@ -17,7 +17,6 @@ import Prelude (take, dropWhile) import Yi.Prelude import Yi.Buffer-import Yi.Buffer.Implementation import Yi.Style import Yi.Syntax import Yi.UI.Cocoa.Utils@@ -32,7 +31,7 @@ import qualified Data.ByteString.Lazy as LB import Foundation hiding (minimum, new, init, null, error)-import AppKit hiding (concat, dictionary)+import AppKit hiding (concat, dictionary, convertAttributes) -- Unfortunately, my version of hoc does not handle typedefs correctly, -- and thus misses every selector that uses the "unichar" type, even@@ -114,13 +113,13 @@ strokeRangeExtent :: Num t => t strokeRangeExtent = 2000 -type Picture = [(Point, Style)]+type Picture = [(Point, Attributes)] $(declareClass "YiTextStorage" "NSTextStorage") $(exportClass "YiTextStorage" "yts_" [ InstanceVariable "buffer" [t| Maybe FBuffer |] [| Nothing |] , InstanceVariable "uiStyle" [t| Maybe UIStyle |] [| Nothing |]- , InstanceVariable "dictionaryCache" [t| M.Map Style (NSDictionary ()) |] [| M.empty |]+ , InstanceVariable "dictionaryCache" [t| M.Map Attributes (NSDictionary ()) |] [| M.empty |] , InstanceVariable "pictureCacheStart" [t| Point |] [| 0 |] , InstanceVariable "pictureCache" [t| Picture |] [| [] |] , InstanceVariable "stringCache" [t| Maybe (NSString ()) |] [| Nothing |]@@ -166,14 +165,13 @@ logPutStrLn $ "yts_attributesAtIndexEffectiveRange " ++ show i ++ " => " ++ show (NSRange i (fromIntegral end)) ++ " " ++ show (take 1 pic) safePoke er (NSRange i (fromIntegral end - i)) dicts <- slf #. _dictionaryCache- let s' = flattenStyle s -- Keep a cache of seen styles... usually, there should not be to many -- TODO: Have one centralized cache instead of one per text storage...- case M.lookup s' dicts of+ case M.lookup s dicts of Just dict -> return dict _ -> do- dict <- convertStyle s'- slf # setIVar _dictionaryCache (M.insert s' dict dicts)+ dict <- convertAttributes s+ slf # setIVar _dictionaryCache (M.insert s dict dicts) return dict yts_attributeAtIndexEffectiveRange :: forall t. NSString t -> CUInt -> NSRangePointer -> YiTextStorage () -> IO (ID ())@@ -196,10 +194,9 @@ -- TODO: Adjust line break property... safePokeFullRange >> castObject <$> defaultParagraphStyle _NSParagraphStyle "NSBackgroundColor" -> do- ~((s,bg):_) <- onlyBg <$> slf # storagePicture i- let Background c = fromMaybe (Background Default) (listToMaybe bg)+ ~((s,a):_) <- onlyBg <$> slf # storagePicture i safePoke er (NSRange i (fromIntegral s - i))- castObject <$> getColor False c+ castObject <$> getColor False (background a) _ -> do -- TODO: Optimize the other queries as well (if needed) logPutStrLn $ "Unoptimized yts_attributeAtIndexEffectiveRange " ++ attr' ++ " at " ++ show i@@ -216,12 +213,6 @@ yts_setAttributesRange :: forall t. NSDictionary t -> NSRange -> YiTextStorage () -> IO () yts_setAttributesRange _ _ _ = return () -flattenStyle :: Style -> Style-flattenStyle xs = catMaybes- [ listToMaybe [fg | fg@(Foreground _) <- xs]- , listToMaybe [bg | bg@(Background _) <- xs]- ]- -- | Remove element x_i if f(x_i,x_(i+1)) is true filter2 :: (a -> a -> Bool) -> [a] -> [a] filter2 _f [] = []@@ -229,28 +220,22 @@ filter2 f (x1:x2:xs) = (if f x1 x2 then id else (x1:)) $ filter2 f (x2:xs) --- | Remove empty style-spans-filterEmpty :: Picture -> Picture-filterEmpty = filter2 ((==) `on` fst)- -- | Merge needless style-span breaks filterSame :: Picture -> Picture filterSame = filter2 ((==) `on` snd) -- | Keep only the background information onlyBg :: Picture -> Picture-onlyBg xs = filterSame [(p,[s | s@(Background _) <- ss]) | (p,ss) <- xs ]+onlyBg = filter2 ((==) `on` (background . snd)) -- | Get a picture where each component (p,style) means apply the style -- up until the given point p.-paintCocoaPicture :: UIStyle -> Point -> [[Stroke]] -> Picture-paintCocoaPicture sty end =- tail . stylesift [] . paintPicture [] . fmap (fmap styleStroke)+paintCocoaPicture :: UIStyle -> Point -> Picture -> Picture+paintCocoaPicture sty end = tail . stylesift (baseAttributes sty) where -- Turn a picture of use style from p into a picture of use style until p stylesift s [] = [(end,s)] stylesift s ((p,t):xs) = (p,s):(stylesift t xs)- styleStroke (l,s,r) = (l,flattenStyle . (s sty ++),r) -- | A version of poke that does nothing if p is null. safePoke :: (Storable a) => Ptr a -> a -> IO ()@@ -267,9 +252,9 @@ bufferPicture :: UIStyle -> FBuffer -> Point -> Picture bufferPicture sty buf p =- let q = (p + strokeRangeExtent) in- paintCocoaPicture sty q $- runBufferDummyWindow buf (strokesRangesB Nothing p q)+ let r = mkSizeRegion p strokeRangeExtent in+ paintCocoaPicture sty (regionEnd r) $+ runBufferDummyWindow buf (attributesPictureB sty Nothing r []) type TextStorage = YiTextStorage () initializeClass_TextStorage :: IO ()
Yi/UI/Cocoa/TextView.hs view
@@ -20,7 +20,6 @@ )where import Yi.Buffer hiding (runBuffer)-import Yi.Buffer.HighLevel import Foundation import AppKit
Yi/UI/Cocoa/Utils.hs view
@@ -40,25 +40,20 @@ userFixedPitchFontOfSize 0 _NSFont >>= flip setFont view -- | Convert style information into Cocoa compatible format-convertStyle :: Style -> IO (NSDictionary ())-convertStyle s = do+convertAttributes :: Attributes -> IO (NSDictionary ())+convertAttributes s = do d <- castObject <$> dictionary _NSMutableDictionary ft <- userFixedPitchFontOfSize 0 _NSFont setValueForKey ft nsFontAttributeName d- fillStyleDict d s+ fillAttributeDict d s castObject <$> return d -- | Fill and return the filled dictionary with the style information-fillStyleDict :: NSMutableDictionary t -> Style -> IO ()-fillStyleDict _ [] = return ()-fillStyleDict d (x:xs) = do- fillStyleDict d xs- getDictStyle x >>= flip (uncurry setValueForKey) d---- | Return a (value, key) pair for insertion into the style dictionary-getDictStyle :: Attr -> IO (NSColor (), NSString ())-getDictStyle (Foreground c) = (,) <$> getColor True c <*> pure nsForegroundColorAttributeName-getDictStyle (Background c) = (,) <$> getColor False c <*> pure nsBackgroundColorAttributeName+fillAttributeDict :: NSMutableDictionary t -> Attributes -> IO ()+fillAttributeDict d a = do+ getColor True (foreground a) >>= setForKey nsForegroundColorAttributeName+ getColor False (background a) >>= setForKey nsBackgroundColorAttributeName+ where setForKey k = \v -> setValueForKey v k d -- | Convert a Yi color into a Cocoa color getColor :: Bool -> Color -> IO (NSColor ())
Yi/UI/Common.hs view
@@ -15,4 +15,14 @@ reloadProject :: FilePath -> IO () -- ^ Reload cabal project views } -+dummyUI :: UI+dummyUI = UI+ {+ main = return (),+ end = return (),+ suspend = return (),+ refresh = const (return ()),+ userForceRefresh = return (),+ prepareAction = return (return ()),+ reloadProject = const (return ())+ }
Yi/UI/Gtk.hs view
@@ -8,23 +8,19 @@ import Prelude (filter, map, round, length, take, FilePath) import Yi.Prelude -import Yi.Accessor-import Yi.Buffer.Implementation (inBounds, Update(..), UIUpdate(..)) import Yi.Buffer-import Yi.Buffer.HighLevel (setSelectionMarkPointB)+import Yi.Buffer.Implementation (inBounds) import qualified Yi.Editor as Editor import Yi.Editor hiding (windows) import qualified Yi.Window as Window import Yi.Window (Window) import Yi.Event import Yi.Keymap-import Yi.Debug import Yi.Monad import qualified Yi.UI.Common as Common import Yi.Config-import Yi.Style hiding (modeline)+import Yi.Style as Style import qualified Yi.WindowSet as WS- import Control.Applicative import Control.Concurrent ( yield ) import Control.Monad (ap)@@ -33,17 +29,19 @@ import Data.Foldable import Data.IORef-import Data.List ( nub, findIndex, sort )+import Data.List (drop, nub, findIndex, sort, zip) import Data.Maybe+import Data.Monoid import Data.Traversable import Data.Unique import qualified Data.Map as M -import Graphics.UI.Gtk hiding ( Window, Event, Action, Point, Style )+import Graphics.UI.Gtk hiding ( Window, Event, Action, Point, Style, Region ) import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.ModelView as MView import Yi.UI.Gtk.ProjectTree import Yi.UI.Gtk.Utils+import Yi.UI.Utils import Shim.ProjectContent import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 @@ -63,7 +61,7 @@ data WinInfo = WinInfo {- bufkey :: !BufferRef -- ^ the buffer this window opens to+ winref :: !Window.WindowRef -- ^ The reference of the Yi window this GTK window represents. , wkey :: !Unique , textview :: TextView , modeline :: Label@@ -72,14 +70,13 @@ } instance Show WinInfo where- show w = "W" ++ show (hashUnique $ wkey w) ++ " on " ++ show (bufkey w)+ show w = "W" ++ show (hashUnique $ wkey w) ++ " on " ++ show (winref w) --- | Get the identification of a window.-winkey :: WinInfo -> (Bool, BufferRef)-winkey w = (isMini w, bufkey w)+bufkey :: Editor -> WinInfo -> BufferRef+bufkey e w = Window.bufkey $ findWindowWith (winref w) e mkUI :: UI -> Common.UI-mkUI ui = Common.UI+mkUI ui = Common.dummyUI { Common.main = main ui, Common.end = postGUIAsync $ end,@@ -222,9 +219,9 @@ syncWindows :: Editor -> UI -> [(Window, Bool)] -- ^ windows paired with their "isFocused" state. -> [WinInfo] -> IO [WinInfo] syncWindows e ui (wfocused@(w,focused):ws) (c:cs)- | Window.winkey w == winkey c = do when focused (setFocus c)- return (c:) `ap` syncWindows e ui ws cs- | Window.winkey w `elem` map winkey cs = removeWindow ui c >> syncWindows e ui (wfocused:ws) cs+ | Window.wkey w == winref c = do when focused (setFocus c)+ return (c:) `ap` syncWindows e ui ws cs+ | Window.wkey w `elem` map winref cs = removeWindow ui c >> syncWindows e ui (wfocused:ws) cs | otherwise = do c' <- insertWindowBefore e ui w c when focused (setFocus c') return (c':) `ap` syncWindows e ui ws (c:cs)@@ -267,7 +264,7 @@ logPutStrLn $ "Will focus to index: " ++ show (findIndex ((wkey w ==) . wkey) wCache) let editorAction = do- b <- gets $ (bkey . findBufferWith (bufkey w))+ b <- gets $ \editor -> bkey $ findBufferWith (bufkey editor w) editor case (eventClick event, eventButton event) of (SingleClick, LeftButton) -> do focusWindow@@ -296,8 +293,9 @@ -- | Make A new window-newWindow :: UI -> Bool -> FBuffer -> IO WinInfo-newWindow ui mini b = do+newWindow :: Editor -> UI -> Bool -> Window -> IO WinInfo+newWindow editor ui mini win = do+ let buf = findBufferWith (Window.bufkey win) editor f <- mkFontDesc (uiConfig ui) ml <- labelNew Nothing@@ -309,28 +307,19 @@ widgetModifyFont v (Just f) -- Apply the window style attributes to the text view.- forM_ (window $ configStyle $ uiConfig ui) $ \styAttr ->- case styAttr of- Background c -> do- let toColor Default = Color 0xffff 0xffff 0xffff- toColor Reverse = Color 0 0 0- toColor (RGB r g b) = Color (fromIntegral r * 0xff) (fromIntegral g * 0xff) (fromIntegral b * 0xff)- widgetModifyBase v StateNormal $ toColor c- _ -> return ()- {- Should be something like below. However, widgetModifyCursor is not in my version of- - gtk2hs! -CROC- Foreground c -> do- let toColor Default = Color 0 0 0- toColor Reverse = Color 0xffff 0xffff 0xffff- toColor (RGB r g b) = Color (fromIntegral r * 0xff) (fromIntegral g * 0xff) (fromIntegral b * 0xff)- widgetModifyCursor v StateNormal $ toColor c- -}+ let styAttr = baseAttributes $ configStyle $ uiConfig ui+ widgetModifyBase v StateNormal $ toColor True $ Style.background styAttr+ widgetModifyText v StateNormal $ toColor False $ Style.foreground styAttr+ {- Should be something like below. However, widgetModifyCursor is not in my version of+ - gtk2hs! -CROC+ widgetModifyCursor v StateNormal $ toColor $ foreground styAttr+ -} box <- if mini then do widgetSetSizeRequest v (-1) 1 - prompt <- labelNew (Just $ name b)+ prompt <- labelNew (Just $ name buf) widgetModifyFont prompt (Just f) hb <- hBoxNew False 1@@ -353,20 +342,20 @@ boxChildPacking ml := PackNatural] return (castToBox vb) - gtkBuf <- getGtkBuffer ui b+ gtkBuf <- getGtkBuffer ui buf textViewSetBuffer v gtkBuf k <- newUnique- let win = WinInfo {- bufkey = (keyB b)+ let gtkWin = WinInfo {+ winref = Window.wkey win , wkey = k , textview = v , modeline = ml , widget = box , isMini = mini }- return win+ return gtkWin insertWindowBefore :: Editor -> UI -> Window -> WinInfo -> IO WinInfo insertWindowBefore e i w _c = insertWindow e i w@@ -376,8 +365,7 @@ insertWindow :: Editor -> UI -> Window -> IO WinInfo insertWindow e i win = do- let buf = findBufferWith (Window.bufkey win) e- liftIO $ do w <- newWindow i (Window.isMini win) buf+ liftIO $ do w <- newWindow e i (Window.isMini win) win set (uiBox i) [containerChild := widget w, boxChildPacking (widget w) := if isMini w then PackNatural else PackGrow] textview w `onButtonRelease` handleClick i w@@ -391,26 +379,35 @@ let ws = Editor.windows e let takeEllipsis s = if length s > 132 then take 129 s ++ "..." else s set (uiCmdLine ui) [labelText := takeEllipsis (statusLine e)]- cache <- readRef $ windowCache ui++ -- Update the GTK text buffers for all the updates that have occured in the backing Yi buffers+ -- since the last refresh.+ -- Iterate over all the buffers in the editor forM_ (buffers e) $ \buf -> when (not $ null $ pendingUpdates $ buf) $ do+ -- Apply all pending updates. gtkBuf <- getGtkBuffer ui buf forM_ ([u | TextUpdate u <- pendingUpdates buf]) $ applyUpdate gtkBuf- let (size,p) = runBufferDummyWindow buf ((,) <$> sizeB <*> pointB)- replaceTagsIn ui (inBounds (p-100) size) (inBounds (p+100) size) buf gtkBuf- forM_ ([(s,s+~l) | StyleUpdate s l <- pendingUpdates buf]) $ \(s,e') -> replaceTagsIn ui (inBounds s size) (inBounds e' size) buf gtkBuf+ let size = runBufferDummyWindow buf sizeB+ forM_ ([mkSizeRegion s l | StyleUpdate s l <- pendingUpdates buf]) $ \r -> replaceTagsIn ui r buf gtkBuf+ -- Update all the tags in each region that is currently displayed.+ -- As multiple windows can be displaying the same buffer this is done for each window.+ forM_ ws $ \w -> when (Window.bufkey w == bkey buf) $ do + let p = fst $ runBuffer w buf pointB+ replaceTagsIn ui (mkRegion (max 0 (p-100)) (min (p+100) size)) buf gtkBuf logPutStrLn $ "syncing: " ++ show ws logPutStrLn $ "with: " ++ show cache cache' <- syncWindows e ui (toList $ WS.withFocus $ ws) cache logPutStrLn $ "Gives: " ++ show cache' writeRef (windowCache ui) cache' forM_ cache' $ \w ->- do let buf = findBufferWith (bufkey w) e+ do let buf = findBufferWith (bufkey e w) e+ win = findWindowWith (winref w) e gtkBuf <- getGtkBuffer ui buf - let (Point p0) = runBufferDummyWindow buf pointB- let (Point p1) = runBufferDummyWindow buf (getMarkPointB staticSelMark)- let (showSel) = runBufferDummyWindow buf (getA highlightSelectionA)+ let (Point p0) = fst $ runBuffer win buf pointB+ let (Point p1) = fst $ runBuffer win buf (getMarkPointB staticSelMark)+ let (showSel) = fst $ runBuffer win buf (getA highlightSelectionA) i <- textBufferGetIterAtOffset gtkBuf p0 if showSel then do@@ -420,21 +417,21 @@ textBufferPlaceCursor gtkBuf i insertMark <- textBufferGetInsert gtkBuf textViewScrollMarkOnscreen (textview w) insertMark- let txt = runBufferDummyWindow buf getModeLine+ let txt = fst $ runBuffer win buf getModeLine set (modeline w) [labelText := txt] -replaceTagsIn :: UI -> Point -> Point -> FBuffer -> TextBuffer -> IO ()-replaceTagsIn ui from to buf gtkBuf = do- i <- textBufferGetIterAtOffset gtkBuf (fromPoint from)- i' <- textBufferGetIterAtOffset gtkBuf (fromPoint to)- let styleSpans = runBufferDummyWindow buf (strokesRangesB Nothing from to)+replaceTagsIn :: UI -> Region -> FBuffer -> TextBuffer -> IO ()+replaceTagsIn ui r buf gtkBuf = do+ i <- textBufferGetIterAtOffset gtkBuf (fromPoint $ regionStart r)+ i' <- textBufferGetIterAtOffset gtkBuf (fromPoint $ regionEnd r)+ let (sizeBuf, styleRanges) = + runBufferDummyWindow buf $ (,) <$> sizeB <*> (attributesPictureB (configStyle $ uiConfig ui) Nothing r []) textBufferRemoveAllTags gtkBuf i i'- forM_ (concat styleSpans) $ \(l,s,r) -> do+ forM_ (zip styleRanges (map fst (drop 1 styleRanges) ++ [sizeBuf]) ) $ \((l,s),r) -> do f <- textBufferGetIterAtOffset gtkBuf (fromPoint l) t <- textBufferGetIterAtOffset gtkBuf (fromPoint r)- forM (s (configStyle $ uiConfig $ ui)) $ \a -> do - tag <- styleToTag ui a- textBufferApplyTag gtkBuf tag f t+ tags <- styleToTag ui s+ forM tags $ \tag -> textBufferApplyTag gtkBuf tag f t applyUpdate :: TextBuffer -> Update -> IO () applyUpdate buf (Insert (Point p) _ s) = do@@ -446,10 +443,10 @@ i1 <- textBufferGetIterAtOffset buf (fromPoint p + length (LazyUTF8.toString s)) textBufferDelete buf i0 i1 -styleToTag :: UI -> Yi.Style.Attr -> IO TextTag+styleToTag :: UI -> Attributes -> IO [TextTag] styleToTag ui a = case a of- (Foreground col) -> tagOf textTagForeground col- (Background col) -> tagOf textTagBackground col+ (Attributes f b) -> sequence [tagOf textTagForeground f, tagOf textTagBackground b]+ where tagOf attr col = do let fgText = colorToText col mtag <- textTagTableLookup (tagTable ui) fgText@@ -513,5 +510,10 @@ revertPendingUpdatesB (,) <$> elemsB <*> sizeB textBufferSetText buf txt- replaceTagsIn ui 0 sz b buf+ replaceTagsIn ui (mkRegion 0 sz) b buf return buf++toColor :: Bool -> Style.Color -> Gtk.Color+toColor fg Default = let c = if fg then 0xff else 0 in Color c c c+toColor fg Reverse = let c = if fg then 0 else 0xff in Color c c c+toColor _g (RGB r g b) = Color (fromIntegral r * 0xff) (fromIntegral g * 0xff) (fromIntegral b * 0xff)
Yi/UI/Pango.hs view
@@ -9,20 +9,16 @@ import Prelude (filter, map, round, length, take, FilePath, (/), subtract, zipWith) import Yi.Prelude -import Yi.Accessor import Yi.Buffer-import Yi.Buffer.HighLevel (setSelectionMarkPointB, getSelectRegionB)-import Yi.Buffer.Region import qualified Yi.Editor as Editor import Yi.Editor hiding (windows) import Yi.Window import Yi.Event import Yi.Keymap-import Yi.Debug import Yi.Monad import qualified Yi.UI.Common as Common import Yi.Config-import Yi.Style hiding (modeline)+import Yi.Style import qualified Yi.WindowSet as WS import Control.Applicative@@ -72,7 +68,7 @@ show w = show (coreWin w) mkUI :: UI -> Common.UI-mkUI ui = Common.UI+mkUI ui = Common.dummyUI { Common.main = main ui, Common.end = end,@@ -459,19 +455,15 @@ -- add color attributes. let (strokes,selectReg,selVisible) = runBufferDummyWindow b $ (,,)- <$> strokesRangesB (regex e) (regionStart r'') (regionEnd r'')+ <$> strokesRangesB (regex e) r'' <*> getSelectRegionB <*> getA highlightSelectionA regInWin = fmapRegion (subtract (regionStart r'')) (intersectRegion selectReg r'')- styleToAttrs (l,attrs,r) = [mkAttr l r a | a <- attrs (configStyle $ uiConfig $ ui)]- mkAttr l r (Foreground col) = AttrForeground (fromPoint (l - regionStart r'')) (fromPoint (r - regionStart r'')) (mkCol col)- mkAttr l r (Background col) = AttrBackground (fromPoint (l - regionStart r'')) (fromPoint (r - regionStart r'')) (mkCol col) allAttrs = (if selVisible then (AttrBackground (fromPoint (regionStart regInWin)) (fromPoint (regionEnd regInWin - 1)) (Color 50000 50000 maxBound) :)- else id)- (concatMap styleToAttrs (concat strokes))+ else id) [] layoutSetAttributes layout allAttrs
Yi/UI/TabBar.hs view
@@ -9,7 +9,7 @@ data TabDescr = TabDescr { tabText :: String,- tabStyle :: Style,+ tabAttributes :: Attributes, tabInFocus :: Bool } @@ -20,8 +20,8 @@ -- TODO: Use different styles for oofTabStyle and ifTabStyle. -- I tried using modeline and modelineFocused but this had an undesired -- effect on the mode line. - CROC- let oofTabStyle = modeline uiStyle- ifTabStyle = modeline uiStyle+ let oofTabStyle = modelineAttributes uiStyle+ ifTabStyle = modelineAttributes uiStyle hintForTab tab = hint where currentBufferName = name $ findBufferWith (bufkey $ current tab) editor hint = if length currentBufferName > maxWidth
Yi/UI/Utils.hs view
@@ -4,12 +4,13 @@ -- Utilities shared by various UIs import Yi.Buffer-import Yi.Buffer.HighLevel import Yi.Prelude import Prelude (Ordering(..)) import Yi.Window import Control.Arrow (second)-+import Data.Monoid+import Yi.Style+import Yi.Syntax (Stroke) -- | return index of Sol on line @n@ above current line indexOfSolAbove :: Int -> BufferM Point indexOfSolAbove n = savingPointB $ do@@ -32,14 +33,14 @@ -- ensure that the points are strictly increasing and introducing -- padding segments where neccessary. -- Precondition: Strokes are ordered and not overlapping.-strokePicture :: [(Point,(a -> a),Point)] -> [(Point,(a -> a))]+strokePicture :: [(Point,Endo a,Point)] -> [(Point,(a -> a))] strokePicture [] = [] strokePicture wholeList@((leftMost,_,_):_) = helper leftMost wholeList- where helper :: Point -> [(Point,(a -> a),Point)] -> [(Point,(a -> a))]+ where helper :: Point -> [(Point,Endo a,Point)] -> [(Point,(a -> a))] helper prev [] = [(prev,id)] helper prev ((l,f,r):xs) - | prev < l = (prev, id) : (l,f) : helper r xs- | otherwise = (l,f) : helper 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)]@@ -53,6 +54,13 @@ -paintPicture :: a -> [[(Point,(a -> a),Point)]] -> [(Point,a)]+paintPicture :: a -> [[(Point,Endo a,Point)]] -> [(Point,a)] paintPicture a = foldr (paintStrokes id a . strokePicture) []++attributesPictureB :: UIStyle -> Maybe SearchExp -> Region -> [[(Point,StyleName,Point)]] -> BufferM [(Point,Attributes)]+attributesPictureB sty mexp region extraLayers =+ paintPicture (baseAttributes sty) <$>+ fmap (fmap $ \(l,s,r) -> (l,s sty, r)) <$>+ (extraLayers ++) <$>+ strokesRangesB mexp region
Yi/UI/Vty.hs view
@@ -9,6 +9,7 @@ import Yi.Prelude hiding ((<|>)) import Prelude (map, take, zip, repeat, length, break, splitAt)+import Control.Arrow import Control.Concurrent import Control.Exception import Control.Monad (forever)@@ -20,13 +21,11 @@ import Data.List (partition, sort, nub) import qualified Data.Map as M import Data.Maybe+import Data.Monoid import Data.Traversable import System.Exit import System.Posix.Signals ( raiseSignal, sigTSTP ) import Yi.Buffer-import Yi.Buffer.Implementation-import Yi.Buffer.Region-import Yi.Buffer.HighLevel import Yi.Config import Yi.Editor import Yi.Event@@ -44,8 +43,6 @@ import Yi.UI.Utils import Yi.UI.TabBar-import Yi.Syntax (Stroke)-import Yi.Buffer.Indent (indentSettingsB) ------------------------------------------------------------------------ @@ -68,15 +65,14 @@ } mkUI :: UI -> Common.UI-mkUI ui = Common.UI +mkUI ui = Common.dummyUI { Common.main = main ui, Common.end = end ui, Common.suspend = raiseSignal sigTSTP, Common.refresh = scheduleRefresh ui, Common.prepareAction = prepareAction ui,- Common.userForceRefresh = userForceRefresh ui,- Common.reloadProject = \_ -> return ()+ Common.userForceRefresh = userForceRefresh ui } -- | Initialise the ui@@ -197,7 +193,7 @@ let startXs = scanrT (+) windowStartY (fmap height ws') wImages = fmap picture renders- statusBarStyle = window $ configStyle $ configUI $ config $ ui+ statusBarStyle = baseAttributes $ configStyle $ configUI $ config $ ui tabBarImages = renderTabBar e' ui xss WS.debug "Drawing: " ws' logPutStrLn $ "startXs: " ++ show startXs@@ -206,7 +202,7 @@ <-> vertcat (toList wImages) <-> - withStyle statusBarStyle (take xss $ cmd ++ repeat ' '),+ withAttributes statusBarStyle (take xss $ cmd ++ repeat ' '), pCursor = case cursor (WS.current renders) of Just (y,x) -> Cursor x (y + WS.current startXs) -- Add the position of the window to the position of the cursor@@ -239,8 +235,8 @@ -- added to make them the same. Otherwise Vty will error out when trying to -- vertically concat two images with different widths. extraCount = xss - (tabWidth * WS.size tabImages)- extraStyle = modeline $ configStyle $ configUI $ config $ ui- extraImage = withStyle extraStyle $ replicate extraCount '#'+ extraStyle = modelineAttributes $ configStyle $ configUI $ config $ ui+ extraImage = withAttributes extraStyle $ replicate extraCount '#' finalImage = if extraCount /= 0 then foldr (<|>) extraImage tabImages else foldr1 (<|>) tabImages@@ -251,7 +247,7 @@ tabToVtyImage width (TabDescr txt sty inFocus) = let pad = replicate (width - length txt - 5) ' ' spacers = if inFocus then (">>", "<<") else (" ", " ")- in withStyle sty $ (fst spacers) ++ txt ++ (snd spacers) ++ pad ++ "|"+ in withAttributes sty $ (fst spacers) ++ txt ++ (snd spacers) ++ pad ++ "|" scanrT :: (Int -> Int -> Int) -> Int -> WindowSet Int -> WindowSet Int scanrT (+*+) k t = fst $ runState (mapM f t) k@@ -292,25 +288,26 @@ -- off reserves space for the mode line. The mini window does not have a mode line. off = if notMini then 1 else 0 h' = height win - off- wsty = styleToAttr (window sty) attr- selsty = styleToAttr (selected sty) attr- eofsty = eof sty- (selreg, _) = runBuffer win b getSelectRegionB+ ground = baseAttributes sty+ wsty = attributesToAttr ground attr+ eofsty = appEndo (eofStyle sty) ground+ (selReg, _) = runBuffer win b getSelectRegionB (point, _) = runBuffer win b pointB (eofPoint, _) = runBuffer win b sizeB- sz = Size (w*h')+ region = mkSizeRegion fromMarkPoint (Size (w*h')) -- 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 (WinMarks fromM _ _ toM), _) = runBuffer win b (getMarks win) fromMarkPoint = if notMini then fst $ runBuffer win b (getMarkPointB fromM) else Point 0- (text, _) = runBuffer win b (streamB Forward fromMarkPoint) -- read enough chars from the buffer.- (strokes, _) = runBuffer win b (strokesRangesB mre fromMarkPoint (fromMarkPoint +~ sz)) -- corresponding strokes- colors = paintPicture attr (map (map (toVtyStroke sty)) strokes)- bufData = -- trace (unlines (map show text) ++ unlines (map show $ concat strokes)) $ - paintChars attr colors $ toIndexedString fromMarkPoint text+ (text, _) = runBuffer win b (indexedStreamB Forward fromMarkPoint) -- read chars from the buffer, lazily (showSel, _) = runBuffer win b (gets highlightSelection)+ extraLayers = if showSel then [[(regionStart selReg, selectedStyle, regionEnd selReg)]] else []+ (picture, _) = runBuffer win b (attributesPictureB sty mre region extraLayers)+ colors = map (second (($ attr) . attributesToAttr)) picture+ bufData = -- trace (unlines (map show text) ++ unlines (map show $ concat strokes)) $ + paintChars attr colors text tabWidth = tabSize . fst $ runBuffer win b indentSettingsB prompt = if isMini win then name b else "" @@ -318,18 +315,16 @@ fromMarkPoint point tabWidth- (if showSel then selreg else emptyRegion)- selsty wsty ([(c,(wsty, (-1))) | c <- prompt] ++ bufData ++ [(' ',(wsty, eofPoint))]) -- we always add one character which can be used to position the cursor at the end of file (_, b') = runBuffer win b (setMarkPointB toM toMarkPoint') (modeLine0, _) = runBuffer win b getModeLine modeLine = if notMini then Just modeLine0 else Nothing- modeLines = map (withStyle (modeStyle sty) . take w . (++ repeat ' ')) $ maybeToList $ modeLine- modeStyle = if focused then modelineFocused else modeline + modeLines = map (withAttributes modeStyle . take w . (++ repeat ' ')) $ maybeToList $ modeLine+ modeStyle = (if focused then appEndo (modelineFocusStyle sty) else id) (modelineAttributes sty) filler = take w (configWindowFill cfg : repeat ' ') - pict = vertcat (take h' (rendered ++ repeat (withStyle eofsty filler)) ++ modeLines)+ pict = vertcat (take h' (rendered ++ repeat (withAttributes eofsty filler)) ++ modeLines) -- | Renders text in a rectangle. -- This also returns @@ -340,15 +335,9 @@ -> Point -- ^ The position of the first character to draw -> Point -- ^ The position of the cursor -> Int -- ^ The number of spaces to represent a tab character with.- -> Region -- ^ The selected region- -> Vty.Attr -- ^ The attribute with which to draw selected text- -> Vty.Attr -- ^ The attribute with which to draw the background- -- this is not used for drawing but only to compare- -- it against the selection attribute to avoid making- -- the selection invisible. -> [(Char,(Vty.Attr,Point))] -- ^ The data to draw. -> ([Image], Point, Maybe (Int,Int))-drawText h w topPoint point tabWidth selreg selsty wsty bufData+drawText h w topPoint point tabWidth bufData | h == 0 || w == 0 = ([], topPoint, Nothing) | otherwise = (rendered_lines, bottomPoint, pntpos) where @@ -363,20 +352,13 @@ -- fill lines with blanks, so the selection looks ok. rendered_lines = map fillColorLine lns0- colorChar (c, (a, x)) = renderChar (pointStyle x a) c-- pointStyle :: Point -> Vty.Attr -> Vty.Attr- pointStyle x a - | x == point = a- | x `inRegion` selreg - && selsty /= wsty = selsty- | otherwise = a+ colorChar (c, (a, aPoint)) = renderChar a c fillColorLine :: [(Char, (Vty.Attr, Point))] -> Image fillColorLine [] = renderHFill attr ' ' w fillColorLine l = horzcat (map colorChar l) <|>- renderHFill (pointStyle x a) ' ' (w - length l)+ renderHFill a ' ' (w - length l) where (_,(a,x)) = last l -- | Cut a string in lines separated by a '\n' char. Note@@ -400,8 +382,8 @@ | ord c < 32 = [('^',p),(chr (ord c + 64),p)] | otherwise = [(c,p)] -withStyle :: Style -> String -> Image-withStyle sty str = renderBS (styleToAttr sty attr) (B.pack str)+withAttributes :: Attributes -> String -> Image+withAttributes sty str = renderBS (attributesToAttr sty attr) (B.pack str) ------------------------------------------------------------------------@@ -456,53 +438,33 @@ ------------------------------------------------------------------------ -- | Convert a Yi Attr into a Vty attribute change.-attrToAttr :: Style.Attr -> (Vty.Attr -> Vty.Attr)-attrToAttr (Foreground c) = - case c of - RGB 0 0 0 -> nullA . setFG Vty.black- RGB 128 128 128 -> boldA . setFG Vty.black- RGB 139 0 0 -> nullA . setFG Vty.red- RGB 255 0 0 -> boldA . setFG Vty.red- RGB 0 100 0 -> nullA . setFG Vty.green- RGB 0 128 0 -> boldA . setFG Vty.green- RGB 165 42 42 -> nullA . setFG Vty.yellow- RGB 255 255 0 -> boldA . setFG Vty.yellow- RGB 0 0 139 -> nullA . setFG Vty.blue- RGB 0 0 255 -> boldA . setFG Vty.blue- RGB 128 0 128 -> nullA . setFG Vty.magenta- RGB 255 0 255 -> boldA . setFG Vty.magenta- RGB 0 139 139 -> nullA . setFG Vty.cyan- RGB 0 255 255 -> boldA . setFG Vty.cyan- RGB 165 165 165 -> nullA . setFG Vty.white- RGB 255 255 255 -> boldA . setFG Vty.white- Default -> nullA . setFG Vty.def- Reverse -> reverseA . setFG Vty.def- _ -> nullA . setFG Vty.black -- NB-attrToAttr (Background c) = +colorToAttr :: (Vty.Attr -> Vty.Attr) -> (Vty.Color -> Vty.Attr -> Vty.Attr) -> Vty.Color -> Style.Color -> (Vty.Attr -> Vty.Attr)+colorToAttr bold set unknown c = case c of - RGB 0 0 0 -> nullA . setBG Vty.black- RGB 128 128 128 -> nullA . setBG Vty.black- RGB 139 0 0 -> nullA . setBG Vty.red- RGB 255 0 0 -> nullA . setBG Vty.red- RGB 0 100 0 -> nullA . setBG Vty.green- RGB 0 128 0 -> nullA . setBG Vty.green- RGB 165 42 42 -> nullA . setBG Vty.yellow- RGB 255 255 0 -> nullA . setBG Vty.yellow- RGB 0 0 139 -> nullA . setBG Vty.blue- RGB 0 0 255 -> nullA . setBG Vty.blue- RGB 128 0 128 -> nullA . setBG Vty.magenta- RGB 255 0 255 -> nullA . setBG Vty.magenta- RGB 0 139 139 -> nullA . setBG Vty.cyan- RGB 0 255 255 -> nullA . setBG Vty.cyan- RGB 165 165 165 -> nullA . setBG Vty.white- RGB 255 255 255 -> nullA . setBG Vty.white- Default -> nullA . setBG Vty.def- Reverse -> reverseA . setBG Vty.def- _ -> nullA . setBG Vty.white -- NB--styleToAttr :: Style -> (Vty.Attr -> Vty.Attr)-styleToAttr = foldr (.) id . map attrToAttr+ RGB 0 0 0 -> nullA . set Vty.black+ RGB 128 128 128 -> bold . set Vty.black+ RGB 139 0 0 -> nullA . set Vty.red+ RGB 255 0 0 -> bold . set Vty.red+ RGB 0 100 0 -> nullA . set Vty.green+ RGB 0 128 0 -> bold . set Vty.green+ RGB 165 42 42 -> nullA . set Vty.yellow+ RGB 255 255 0 -> bold . set Vty.yellow+ RGB 0 0 139 -> nullA . set Vty.blue+ RGB 0 0 255 -> bold . set Vty.blue+ RGB 128 0 128 -> nullA . set Vty.magenta+ RGB 255 0 255 -> bold . set Vty.magenta+ RGB 0 139 139 -> nullA . set Vty.cyan+ RGB 0 255 255 -> bold . set Vty.cyan+ RGB 165 165 165 -> nullA . set Vty.white+ RGB 255 255 255 -> bold . set Vty.white+ Default -> nullA . set Vty.def+ Reverse -> reverseA . set Vty.def+ _ -> nullA . set unknown -- NB +attributesToAttr :: Attributes -> (Vty.Attr -> Vty.Attr)+attributesToAttr (Attributes fg bg) =+ colorToAttr boldA setFG Vty.black fg .+ colorToAttr nullA setBG Vty.white bg ---------------------------------@@ -512,12 +474,8 @@ -- This routine also does syntax highlighting and applies overlays. paintChars :: a -> [(Point,a)] -> [(Point,Char)] -> [(Char, (a,Point))] paintChars sty [] cs = setSty sty cs-paintChars sty ((endPos,sty'):xs) cs = setSty sty left ++ paintChars sty' xs right- where (left, right) = break ((endPos <=) . fst) cs+paintChars sty ((endPos,sty'):xs) cs = setSty sty before ++ paintChars sty' xs after+ where (before, after) = break ((endPos <=) . fst) cs setSty :: a -> [(Point,Char)] -> [(Char, (a,Point))] setSty sty cs = [(c,(sty,p)) | (p,c) <- cs]--toVtyStroke :: UIStyle -> Stroke -> (Point, Vty.Attr -> Vty.Attr, Point)-toVtyStroke sty (l,s,r) = (l,styleToAttr (s sty),r)-
− Yi/Undo.hs
@@ -1,180 +0,0 @@--- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons--- Copyright (c) 2008 JP Bernardy------- | 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.------- TODO: rename to Yi.Buffer.Undo-module Yi.Undo (- emptyU- , addChangeU- , setSavedFilePointU- , isAtSavedFilePointU- , undoU- , redoU- , URList {- abstractly -}- , Change(AtomicChange, InteractivePoint)- ) where--import Control.Monad (ap)-import Data.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 {-! Binary !-})---- | A URList consists of an undo and a redo list.-data URList = URList [Change] [Change]- deriving (Show {-! Binary !-})---- | 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 :: URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))-undoU ur b = undoUntilInteractive [] (undoInteractive ur) b---- | This redoes one iteraction step.-redoU :: 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 :: [Update] -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))-undoUntilInteractive 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 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 xs ur' b'- in (b'', (ur'', u:xs''))---- | 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--------------------------------------------------------------- DERIVES GENERATED CODE--- DO NOT MODIFY BELOW THIS LINE--- CHECKSUM: 809201852--instance Binary Change- where put (SavedFilePoint) = putWord8 0- put (InteractivePoint) = putWord8 1- put (AtomicChange x1) = putWord8 2 >> put x1- get = getWord8 >>= (\tag_ -> case tag_ of- 0 -> return SavedFilePoint- 1 -> return InteractivePoint- 2 -> ap (return AtomicChange) get)--instance Binary URList- where put (URList x1 x2) = return () >> (put x1 >> put x2)- get = case 0 of- 0 -> ap (ap (return URList) get) get
Yi/Window.hs view
@@ -6,6 +6,8 @@ -- module Yi.Window where+import Control.Monad (ap)+import Data.Binary import Data.Typeable import Yi.Buffer.Basic (BufferRef) @@ -20,7 +22,7 @@ ,height :: !Int -- ^ height of the window (in number of lines displayed) ,wkey :: !WindowRef -- ^ identifier for the window (for UI sync) }- deriving Typeable+ deriving (Typeable {-! Binary !-}) -- | Get the identification of a window. winkey :: Window -> (Bool, BufferRef) winkey w = (isMini w, bufkey w)@@ -43,3 +45,17 @@ dummyWindow :: BufferRef -> Window dummyWindow b = Window False b 0 dummyWindowKey +++--------------------------------------------------------+-- DERIVES GENERATED CODE+-- DO NOT MODIFY BELOW THIS LINE+-- CHECKSUM: 1547716863++instance Binary Window+ where put (Window x1+ x2+ x3+ x4) = return () >> (put x1 >> (put x2 >> (put x3 >> put x4)))+ get = case 0 of+ 0 -> ap (ap (ap (ap (return Window) get) get) get) get
Yi/WindowSet.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-} -- -- Copyright (c) 2007 Jean-Philippe Bernardy --@@ -8,16 +8,17 @@ -- FIXME: export abstractly -- TODO: rename to RoundRobin or somesuch. -import Prelude hiding (elem, error)+import Prelude ()+import Yi.Prelude -import Yi.Debug import Control.Monad.Trans+import Data.Binary import Data.Foldable import Data.Traversable import Data.Monoid+import Data.List hiding (elem) import Control.Applicative import Control.Monad-import Yi.Accessor #ifdef TESTING import Test.QuickCheck @@ -28,7 +29,7 @@ #endif data WindowSet a = WindowSet { before::[a], current::a, after :: [a] }- deriving (Show, Eq)+ deriving (Show, Eq {-! Binary !-}) instance Foldable WindowSet where foldMap f (WindowSet b c a) = getDual (foldMap (Dual . f) b) `mappend` (f c) `mappend` foldMap f a@@ -100,3 +101,15 @@ debug msg (WindowSet b c a) = logPutStrLn $ msg ++ ": " ++ show b ++ show c ++ show a ++--------------------------------------------------------+-- DERIVES GENERATED CODE+-- DO NOT MODIFY BELOW THIS LINE+-- CHECKSUM: 1932088040++instance Binary t1 => Binary (WindowSet t1)+ where put (WindowSet x1+ x2+ x3) = return () >> (put x1 >> (put x2 >> put x3))+ get = case 0 of+ 0 -> ap (ap (ap (return WindowSet) get) get) get
examples/yi-simple.hs view
@@ -4,9 +4,9 @@ increaseIndent :: BufferM () increaseIndent = do- r <- getSelectRegionB- r' <- unitWiseRegion Line r -- extend the region to full lines.- modifyRegionB (mapLines (' ':)) r'+ r <- getSelectRegionB+ r' <- unitWiseRegion Line r -- extend the region to full lines.+ modifyRegionB (mapLines (' ':)) r' main :: IO ()
yi.cabal view
@@ -1,5 +1,5 @@ name: yi-version: 0.4.6.2+version: 0.5.0.1 category: Development, Editor synopsis: The Haskell-Scriptable Editor description:@@ -70,7 +70,9 @@ Yi.Buffer.HighLevel Yi.Buffer.Indent Yi.Buffer.Normal+ Yi.Buffer.Misc Yi.Buffer.Region+ Yi.Buffer.Undo Yi.Completion Yi.Config Yi.Core@@ -136,7 +138,6 @@ Yi.UI.Common Yi.UI.Utils Yi.UI.TabBar- Yi.Undo Yi.Window Yi.WindowSet @@ -321,7 +322,7 @@ Yi.Keymap.Emacs.KillRing, Yi.Keymap.Emacs.Utils, Yi.Main, Yi.MkTemp, Yi.Monad, Yi.Process, Yi.Search, Yi.String, Yi.Style, Yi.Templates, Yi.TextCompletion,- Yi.Undo, Yi.Window, Yi.WindowSet+ Yi.Buffer.Undo, Yi.Window, Yi.WindowSet Yi.MiniBuffer Yi.File Yi.KillRing