diff --git a/Data/ByteRope.hs b/Data/ByteRope.hs --- a/Data/ByteRope.hs +++ b/Data/ByteRope.hs @@ -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 diff --git a/HConf.hs b/HConf.hs --- a/HConf.hs +++ b/HConf.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Yi.hs b/Yi.hs --- a/Yi.hs +++ b/Yi.hs @@ -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 diff --git a/Yi/Boot.hs b/Yi/Boot.hs --- a/Yi/Boot.hs +++ b/Yi/Boot.hs @@ -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 diff --git a/Yi/Boot.hs-boot b/Yi/Boot.hs-boot new file mode 100644 --- /dev/null +++ b/Yi/Boot.hs-boot @@ -0,0 +1,5 @@ +module Yi.Boot where + +import Yi.Keymap + +reloadEditor :: YiM () diff --git a/Yi/Buffer.hs b/Yi/Buffer.hs --- a/Yi/Buffer.hs +++ b/Yi/Buffer.hs @@ -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 diff --git a/Yi/Buffer.hs-boot b/Yi/Buffer.hs-boot deleted file mode 100644 --- a/Yi/Buffer.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Yi.Buffer where - -data AnyMode - -data Mode syntax diff --git a/Yi/Buffer/Basic.hs b/Yi/Buffer/Basic.hs --- a/Yi/Buffer/Basic.hs +++ b/Yi/Buffer/Basic.hs @@ -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 diff --git a/Yi/Buffer/HighLevel.hs b/Yi/Buffer/HighLevel.hs --- a/Yi/Buffer/HighLevel.hs +++ b/Yi/Buffer/HighLevel.hs @@ -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 diff --git a/Yi/Buffer/Implementation.hs b/Yi/Buffer/Implementation.hs --- a/Yi/Buffer/Implementation.hs +++ b/Yi/Buffer/Implementation.hs @@ -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) diff --git a/Yi/Buffer/Indent.hs b/Yi/Buffer/Indent.hs --- a/Yi/Buffer/Indent.hs +++ b/Yi/Buffer/Indent.hs @@ -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)) ' ' diff --git a/Yi/Buffer/Misc.hs b/Yi/Buffer/Misc.hs new file mode 100644 --- /dev/null +++ b/Yi/Buffer/Misc.hs @@ -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 + diff --git a/Yi/Buffer/Normal.hs b/Yi/Buffer/Normal.hs --- a/Yi/Buffer/Normal.hs +++ b/Yi/Buffer/Normal.hs @@ -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 diff --git a/Yi/Buffer/Region.hs b/Yi/Buffer/Region.hs --- a/Yi/Buffer/Region.hs +++ b/Yi/Buffer/Region.hs @@ -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) diff --git a/Yi/Buffer/Undo.hs b/Yi/Buffer/Undo.hs new file mode 100644 --- /dev/null +++ b/Yi/Buffer/Undo.hs @@ -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 diff --git a/Yi/Completion.hs b/Yi/Completion.hs --- a/Yi/Completion.hs +++ b/Yi/Completion.hs @@ -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 diff --git a/Yi/Config.hs b/Yi/Config.hs --- a/Yi/Config.hs +++ b/Yi/Config.hs @@ -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 diff --git a/Yi/Core.hs b/Yi/Core.hs --- a/Yi/Core.hs +++ b/Yi/Core.hs @@ -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] diff --git a/Yi/Dired.hs b/Yi/Dired.hs --- a/Yi/Dired.hs +++ b/Yi/Dired.hs @@ -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, diff --git a/Yi/Dynamic.hs b/Yi/Dynamic.hs --- a/Yi/Dynamic.hs +++ b/Yi/Dynamic.hs @@ -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 diff --git a/Yi/Editor.hs b/Yi/Editor.hs --- a/Yi/Editor.hs +++ b/Yi/Editor.hs @@ -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 - diff --git a/Yi/Eval.hs b/Yi/Eval.hs --- a/Yi/Eval.hs +++ b/Yi/Eval.hs @@ -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 () diff --git a/Yi/File.hs b/Yi/File.hs --- a/Yi/File.hs +++ b/Yi/File.hs @@ -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 () diff --git a/Yi/GHC.hs b/Yi/GHC.hs --- a/Yi/GHC.hs +++ b/Yi/GHC.hs @@ -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 diff --git a/Yi/History.hs b/Yi/History.hs --- a/Yi/History.hs +++ b/Yi/History.hs @@ -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) diff --git a/Yi/IncrementalParse.hs b/Yi/IncrementalParse.hs --- a/Yi/IncrementalParse.hs +++ b/Yi/IncrementalParse.hs @@ -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 diff --git a/Yi/Interpreter.hs b/Yi/Interpreter.hs --- a/Yi/Interpreter.hs +++ b/Yi/Interpreter.hs @@ -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 diff --git a/Yi/Keymap/Cua.hs b/Yi/Keymap/Cua.hs --- a/Yi/Keymap/Cua.hs +++ b/Yi/Keymap/Cua.hs @@ -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, diff --git a/Yi/Keymap/Emacs.hs b/Yi/Keymap/Emacs.hs --- a/Yi/Keymap/Emacs.hs +++ b/Yi/Keymap/Emacs.hs @@ -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) diff --git a/Yi/Keymap/Emacs/KillRing.hs b/Yi/Keymap/Emacs/KillRing.hs --- a/Yi/Keymap/Emacs/KillRing.hs +++ b/Yi/Keymap/Emacs/KillRing.hs @@ -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_ ) diff --git a/Yi/Keymap/Emacs/Utils.hs b/Yi/Keymap/Emacs/Utils.hs --- a/Yi/Keymap/Emacs/Utils.hs +++ b/Yi/Keymap/Emacs/Utils.hs @@ -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 diff --git a/Yi/Keymap/Vim.hs b/Yi/Keymap/Vim.hs --- a/Yi/Keymap/Vim.hs +++ b/Yi/Keymap/Vim.hs @@ -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 \ 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 diff --git a/Yi/KillRing.hs b/Yi/KillRing.hs --- a/Yi/KillRing.hs +++ b/Yi/KillRing.hs @@ -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 diff --git a/Yi/Lexer/Alex.hs b/Yi/Lexer/Alex.hs --- a/Yi/Lexer/Alex.hs +++ b/Yi/Lexer/Alex.hs @@ -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) diff --git a/Yi/Lexer/Haskell.x b/Yi/Lexer/Haskell.x --- a/Yi/Lexer/Haskell.x +++ b/Yi/Lexer/Haskell.x @@ -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 diff --git a/Yi/Lexer/Latex.x b/Yi/Lexer/Latex.x --- a/Yi/Lexer/Latex.x +++ b/Yi/Lexer/Latex.x @@ -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 } { diff --git a/Yi/Lexer/LiterateHaskell.x b/Yi/Lexer/LiterateHaskell.x --- a/Yi/Lexer/LiterateHaskell.x +++ b/Yi/Lexer/LiterateHaskell.x @@ -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 = diff --git a/Yi/Lexer/Perl.x b/Yi/Lexer/Perl.x --- a/Yi/Lexer/Perl.x +++ b/Yi/Lexer/Perl.x @@ -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 } . diff --git a/Yi/Main.hs b/Yi/Main.hs --- a/Yi/Main.hs +++ b/Yi/Main.hs @@ -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 diff --git a/Yi/MiniBuffer.hs b/Yi/MiniBuffer.hs --- a/Yi/MiniBuffer.hs +++ b/Yi/MiniBuffer.hs @@ -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' diff --git a/Yi/Misc.hs b/Yi/Misc.hs --- a/Yi/Misc.hs +++ b/Yi/Misc.hs @@ -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) diff --git a/Yi/Mode/Compilation.hs b/Yi/Mode/Compilation.hs --- a/Yi/Mode/Compilation.hs +++ b/Yi/Mode/Compilation.hs @@ -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 diff --git a/Yi/Mode/Haskell.hs b/Yi/Mode/Haskell.hs --- a/Yi/Mode/Haskell.hs +++ b/Yi/Mode/Haskell.hs @@ -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 diff --git a/Yi/Mode/Interactive.hs b/Yi/Mode/Interactive.hs --- a/Yi/Mode/Interactive.hs +++ b/Yi/Mode/Interactive.hs @@ -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 diff --git a/Yi/Mode/Shim.hs b/Yi/Mode/Shim.hs --- a/Yi/Mode/Shim.hs +++ b/Yi/Mode/Shim.hs @@ -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))) } diff --git a/Yi/Modes.hs b/Yi/Modes.hs --- a/Yi/Modes.hs +++ b/Yi/Modes.hs @@ -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] diff --git a/Yi/Process.hs b/Yi/Process.hs --- a/Yi/Process.hs +++ b/Yi/Process.hs @@ -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 diff --git a/Yi/Rectangle.hs b/Yi/Rectangle.hs --- a/Yi/Rectangle.hs +++ b/Yi/Rectangle.hs @@ -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 diff --git a/Yi/Region.hs b/Yi/Region.hs --- a/Yi/Region.hs +++ b/Yi/Region.hs @@ -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 diff --git a/Yi/Search.hs b/Yi/Search.hs --- a/Yi/Search.hs +++ b/Yi/Search.hs @@ -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 diff --git a/Yi/Style.hs b/Yi/Style.hs --- a/Yi/Style.hs +++ b/Yi/Style.hs @@ -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 diff --git a/Yi/Style/Library.hs b/Yi/Style/Library.hs --- a/Yi/Style/Library.hs +++ b/Yi/Style/Library.hs @@ -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 + } diff --git a/Yi/Syntax/Fractal.hs b/Yi/Syntax/Fractal.hs --- a/Yi/Syntax/Fractal.hs +++ b/Yi/Syntax/Fractal.hs @@ -1,4 +1,3 @@ -{-# OPTIONS -fglasgow-exts #-} module Yi.Syntax.Fractal (parse, getStrokes) where import Yi.Lexer.Alex (Tok(..), tokBegin) diff --git a/Yi/Syntax/Latex.hs b/Yi/Syntax/Latex.hs --- a/Yi/Syntax/Latex.hs +++ b/Yi/Syntax/Latex.hs @@ -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 diff --git a/Yi/Syntax/Layout.hs b/Yi/Syntax/Layout.hs --- a/Yi/Syntax/Layout.hs +++ b/Yi/Syntax/Layout.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yi.Syntax.Layout (layoutHandler, State) where import Yi.Syntax diff --git a/Yi/TextCompletion.hs b/Yi/TextCompletion.hs --- a/Yi/TextCompletion.hs +++ b/Yi/TextCompletion.hs @@ -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 [] diff --git a/Yi/UI/Cocoa.hs b/Yi/UI/Cocoa.hs --- a/Yi/UI/Cocoa.hs +++ b/Yi/UI/Cocoa.hs @@ -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 diff --git a/Yi/UI/Cocoa/TextStorage.hs b/Yi/UI/Cocoa/TextStorage.hs --- a/Yi/UI/Cocoa/TextStorage.hs +++ b/Yi/UI/Cocoa/TextStorage.hs @@ -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 () diff --git a/Yi/UI/Cocoa/TextView.hs b/Yi/UI/Cocoa/TextView.hs --- a/Yi/UI/Cocoa/TextView.hs +++ b/Yi/UI/Cocoa/TextView.hs @@ -20,7 +20,6 @@ )where import Yi.Buffer hiding (runBuffer) -import Yi.Buffer.HighLevel import Foundation import AppKit diff --git a/Yi/UI/Cocoa/Utils.hs b/Yi/UI/Cocoa/Utils.hs --- a/Yi/UI/Cocoa/Utils.hs +++ b/Yi/UI/Cocoa/Utils.hs @@ -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 ()) diff --git a/Yi/UI/Common.hs b/Yi/UI/Common.hs --- a/Yi/UI/Common.hs +++ b/Yi/UI/Common.hs @@ -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 ()) + } diff --git a/Yi/UI/Gtk.hs b/Yi/UI/Gtk.hs --- a/Yi/UI/Gtk.hs +++ b/Yi/UI/Gtk.hs @@ -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) diff --git a/Yi/UI/Pango.hs b/Yi/UI/Pango.hs --- a/Yi/UI/Pango.hs +++ b/Yi/UI/Pango.hs @@ -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 diff --git a/Yi/UI/TabBar.hs b/Yi/UI/TabBar.hs --- a/Yi/UI/TabBar.hs +++ b/Yi/UI/TabBar.hs @@ -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 diff --git a/Yi/UI/Utils.hs b/Yi/UI/Utils.hs --- a/Yi/UI/Utils.hs +++ b/Yi/UI/Utils.hs @@ -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 diff --git a/Yi/UI/Vty.hs b/Yi/UI/Vty.hs --- a/Yi/UI/Vty.hs +++ b/Yi/UI/Vty.hs @@ -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) - diff --git a/Yi/Undo.hs b/Yi/Undo.hs deleted file mode 100644 --- a/Yi/Undo.hs +++ /dev/null @@ -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 diff --git a/Yi/Window.hs b/Yi/Window.hs --- a/Yi/Window.hs +++ b/Yi/Window.hs @@ -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 diff --git a/Yi/WindowSet.hs b/Yi/WindowSet.hs --- a/Yi/WindowSet.hs +++ b/Yi/WindowSet.hs @@ -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 diff --git a/examples/yi-simple.hs b/examples/yi-simple.hs --- a/examples/yi-simple.hs +++ b/examples/yi-simple.hs @@ -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 () diff --git a/yi.cabal b/yi.cabal --- a/yi.cabal +++ b/yi.cabal @@ -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