yi 0.2 → 0.3
raw patch · 71 files changed
+12832/−154 lines, 71 filesdep +HOCdep +HOC-AppKitdep +HOC-Foundationdep ~ghcdep ~regex-posixsetup-changedbinary-added
Dependencies added: HOC, HOC-AppKit, HOC-Foundation, array, bytestring, containers, directory, filepath, fingertree, gtk, old-locale, old-time, process, random, regex-base, regex-compat, unix, vty
Dependency ranges changed: ghc, regex-posix
Files
- LICENSE +0/−29
- Main.hs +27/−24
- Setup.hs +105/−29
- Yi/Accessor.hs +78/−0
- Yi/Boot.hs +69/−37
- Yi/Buffer.hs +489/−0
- Yi/Buffer/HighLevel.hs +301/−0
- Yi/Buffer/Implementation.hs +395/−0
- Yi/Buffer/Normal.hs +254/−0
- Yi/Buffer/Region.hs +56/−0
- Yi/Char.hs +85/−0
- Yi/Completion.hs +42/−0
- Yi/Core.hs +434/−0
- Yi/Debug.hs +11/−7
- Yi/Dired.hs +465/−0
- Yi/Dynamic.hs +38/−0
- Yi/Editor.hs +400/−0
- Yi/Eval.hs +98/−0
- Yi/Event.hs +368/−0
- Yi/File.hs +64/−0
- Yi/FingerString.hs +163/−0
- Yi/History.hs +65/−0
- Yi/Indent.hs +188/−0
- Yi/Interact.hs +292/−0
- Yi/Kernel.hs +35/−14
- Yi/Keymap.hs +164/−0
- Yi/Keymap/Completion.hs +69/−0
- Yi/Keymap/Ee.hs +43/−0
- Yi/Keymap/Emacs.hs +156/−0
- Yi/Keymap/Emacs/Keys.hs +103/−0
- Yi/Keymap/Emacs/KillRing.hs +74/−0
- Yi/Keymap/Emacs/UnivArgument.hs +36/−0
- Yi/Keymap/Emacs/Utils.hs +319/−0
- Yi/Keymap/JP.hs +176/−0
- Yi/Keymap/Joe.hs +282/−0
- Yi/Keymap/Mg.hs +618/−0
- Yi/Keymap/Nano.hs +235/−0
- Yi/Keymap/Vi.hs +544/−0
- Yi/Keymap/Vim.hs +790/−0
- Yi/KillRing.hs +46/−0
- Yi/Main.hs +177/−0
- Yi/MiniBuffer.hs +72/−0
- Yi/MkTemp.hs +253/−0
- Yi/Monad.hs +46/−0
- Yi/Process.hs +59/−0
- Yi/Search.hs +331/−0
- Yi/String.hs +77/−0
- Yi/Style.hs +149/−0
- Yi/Syntax.hs +43/−0
- Yi/Syntax/Cabal.x +180/−0
- Yi/Syntax/Cplusplus.x +225/−0
- Yi/Syntax/Haskell.x +123/−0
- Yi/Syntax/Latex.x +111/−0
- Yi/Syntax/LiterateHaskell.x +176/−0
- Yi/Syntax/Srmc.x +127/−0
- Yi/Syntax/Table.hs +38/−0
- Yi/Syntax/alex.hsinc +123/−0
- Yi/Templates.hs +131/−0
- Yi/TextCompletion.hs +181/−0
- Yi/UI/Cocoa.hs +635/−0
- Yi/UI/Common.hs +18/−0
- Yi/UI/Gtk.hs +445/−0
- Yi/UI/Vty.hs +377/−0
- Yi/Undo.hs +170/−0
- Yi/Vty.hs +83/−0
- Yi/Window.hs +33/−0
- Yi/WindowSet.hs +88/−0
- Yi/Yi.hs +55/−0
- art/yi+lambda-fat.pdf binary
- examples/YiConfig.hs +19/−0
- yi.cabal +110/−14
LICENSE view
@@ -338,32 +338,3 @@ consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License.----------------------------------------------------------------------------The ncurses binding was originally written by John Meacham, and is-available under the license:--Unless otherwise stated the following licence applies:--Copyright (c) 2002-2004 John Meacham (john at repetae dot net)--Permission is hereby granted, free of charge, to any person obtaining a-copy of this software and associated documentation files (the-"Software"), to deal in the Software without restriction, including-without limitation the rights to use, copy, modify, merge, publish,-distribute, sublicense, and/or sell copies of the Software, and to-permit persons to whom the Software is furnished to do so, subject to-the following conditions:--The above copyright notice and this permission notice shall be included-in all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS-OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.-
Main.hs view
@@ -1,21 +1,4 @@------ Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons------ 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 program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU--- General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software--- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA--- 02111-1307, USA.---+-- Copyright (C) 2004, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- | Frontend to the static binary. We have a separte frontend (rather@@ -25,25 +8,45 @@ -- module Main ( main ) where -import Yi.Boot+import qualified Yi.Main as Yi+ import Yi.Debug+import Yi.Kernel+#ifdef DYNAMIC+import Yi.Boot +{- main :: IO () main = do initDebug ".yi-static.dbg" kernel <- initialize Yi.Boot.startYi kernel -- call Yi.main dynamically- +-- TODO: also init the debug system +-} -{--import qualified Yi +import Control.Monad main :: IO () main = do initDebug ".yi-static.dbg" kernel <- initialize++ -- Setup the debug module in the dynamic session (this needs to be done only because+ -- debug uses "global" variables.+ debugMod <- guessTarget kernel "Yi.Debug" Nothing+ setTargets kernel [debugMod]+ loadAllTargets kernel+ initDebug' <- join $ evalMono kernel "Yi.Debug.initDebug \".yi.dbg\""+ initDebug' :: IO ()++ -- Fire up Yi Yi.main kernel- --}++#else+main :: IO ()+main = do+ initDebug ".yi-static.dbg"+ Yi.main Kernel+#endif
Setup.hs view
@@ -1,42 +1,118 @@ #!/usr/bin/env runhaskell module Main where -import Distribution.Simple-import Distribution.Setup+import Control.Applicative+import Control.Monad+import Data.List+import Data.Maybe import Distribution.PackageDescription+import Distribution.Simple import Distribution.Simple.LocalBuildInfo-import System.Info-import System.Process-import Data.List+import Distribution.Simple.Program+import Distribution.Simple.Setup+import System.Directory hiding (copyFile)+import System.FilePath import System.IO-import System.Exit-import Data.Maybe+import Distribution.Simple.Utils (copyFileVerbose)+import Distribution.Verbosity (Verbosity) main :: IO () main = defaultMainWithHooks defaultUserHooks- { postConf = pC, preBuild = setConfigInfo }+ { buildHook = bHook, instHook = install, haddockHook = hdHook, sDistHook = sDist } -pC :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode-pC args a b lbi = do- fmap (const ()) $ (postConf defaultUserHooks) args a b lbi -- call default function (necessary ?)- getLibDir (compilerPath . compiler $ lbi) >>= \libdir ->- writeFile ".libdir" libdir- return $ ExitSuccess- where getLibDir ghcPath = do - (_, out, _, pid) <- runInteractiveProcess ghcPath ["--print-libdir"]- Nothing Nothing- libDir <- hGetLine out- waitForProcess pid- return libDir+bHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+bHook pd lbi hooks flags = do+ pd' <- addPackageOptions pd lbi (buildVerbose flags)+ buildHook defaultUserHooks pd' lbi hooks flags -setConfigInfo args _- = readFile ".libdir" >>= \libdir ->- return- (Nothing,+hdHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()+hdHook pd lbi hooks flags = do+ pd' <- addPackageOptions pd lbi (haddockVerbose flags)+ let pd'' = pseudoLibraryPkg pd' "yi" ["Yi.Yi"]+ haddockHook defaultUserHooks pd'' lbi hooks flags+ putStrLn "Note that you need haddock 2.0 for this to work."++install :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()+install pd lbi hooks flags = do+ curdir <- getCurrentDirectory+ let rel = map . makeRelative+ buildDir = curdir </> "dist" </> "build" </> "yi" </> "yi-tmp"+ sourceFiles <- rel curdir <$> unixFindExt "Yi" [".hs-boot",".hs",".hsinc"]+ targetFiles <- rel buildDir <$> unixFindExt (buildDir </> "Yi") [".hs", ".hi",".o"]+ print targetFiles+ let InstallDirs {datadir = dataPref} = absoluteInstallDirs pd lbi NoCopyDest+ verbosity = installVerbose flags+ -- NOTE: It's important that source files are copied before target files,+ -- otherwise GHC (via Yi) thinks it has to recompile them when Yi is started.++ mapM_ (copyFile verbosity curdir dataPref) sourceFiles+ mapM_ (copyFile verbosity buildDir dataPref) targetFiles+ instHook defaultUserHooks pd lbi hooks flags+++sDist :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()+sDist pd lbi hooks flags = do+ curdir <- getCurrentDirectory+ sources <- (map . makeRelative) curdir <$> unixFindExt (curdir </> "Yi") [".hs",".hsinc",".x"]+ -- Make run-inplace injects some files into the source directory,+ -- we need to make sure not to include those...+ let ss = [s | s <- sources, not (".hs" `isSuffixOf` s) ||+ "Syntax.hs" `isSuffixOf` s ||+ "Table.hs" `isSuffixOf` s ||+ not ("Syntax" `isInfixOf` s)]+ -- Ugly hack that adds all the files we need as dataFiles, since+ -- Cabal seriously don't want to play our game...+ let pd' = pd{+ dataFiles = "Main.hs" : ss ++ dataFiles pd, executables = [], library=Nothing }+ + -- Run the standard hook for our cripled package+ sDistHook defaultUserHooks pd' lbi hooks flags+ ++mkOpt :: (String, String) -> String+mkOpt (name,def) = "-D" ++ name ++ "=" ++ def++-- Add our special package options to+addPackageOptions :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO PackageDescription+addPackageOptions pd lbi verbosity = do+ let dataPref = datadir $ absoluteInstallDirs pd lbi NoCopyDest+ pkgOpts = concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ]+ ghcOut = rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi)+ print dataPref+ libdr <- head . lines <$> ghcOut ["--print-libdir"]+ putStrLn $ "GHC libdir = " ++ show libdr+ let pbi = (Nothing, [("yi", emptyBuildInfo- { options = [(GHC,[mkOpt ("GHC_LIBDIR",show libdir)])] })])- where mkOpt (name,def) = "-D"++name++"="++def+ { options = [(GHC,[mkOpt ("GHC_LIBDIR",show libdr),+ mkOpt ("YI_LIBDIR", show dataPref),+ mkOpt ("YI_PKG_OPTS", show pkgOpts)])] })])+ return $ updatePackageDescription pbi pd --- Marc Weber: I don't like this patch because it's using the .libdir--- file to store the libdir. There must be a better way but I don't--- want to spend more time on this. +-- just pretend that we build a library with the given modules+pseudoLibraryPkg :: PackageDescription -> String -> [String] -> PackageDescription+pseudoLibraryPkg pd name mods =+ pd {package = PackageIdentifier name (Version [] []),+ executables = [],+ library = Just (Library {+ exposedModules = mods,+ libBuildInfo = yiBuildInfo})}+ where [Executable "yi" _ yiBuildInfo] = executables pd++copyFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()+copyFile verbosity srcDir dstDir file = do+ let destination = dstDir </> file+ createDirectoryIfMissing True (dropFileName destination)+ copyFileVerbose verbosity (srcDir </> file) destination+++unixFindExt :: FilePath -> [String] -> IO [FilePath]+unixFindExt dir exts = filter ((`elem` exts) . takeExtension) <$> unixFind dir++unixFind :: FilePath -> IO [FilePath]+unixFind dir = do+ contents0 <- getDirectoryContents dir+ let contents = map (dir </>) $ filter (not . (`elem` [".", ".."])) contents0+ dirs <- filterM doesDirectoryExist contents+ files <- filterM doesFileExist contents+ rec <- mapM unixFind dirs+ return (files ++ concat rec)
+ Yi/Accessor.hs view
@@ -0,0 +1,78 @@+-- Copyright (C) 2008 JP Bernardy+--+++-- | A module for "rich" accesssors.++module Yi.Accessor where+import Control.Monad.State+import Data.Traversable as Traversable+import Data.Foldable++-- | A way to access and modify a part of a complex structure.+-- Categorically, an arrow from @whole@ to @part@.+data Accessor whole part+ = Accessor { getter :: whole -> part,+ modifier :: (part -> part) -> (whole -> whole)+ }++-- Should be made instance of the upcoming Control.Category class as such:+-- import qualified Prelude+-- import Prelude hiding (id,(.))+--+-- instance Category (->) where+-- id = Prelude.id+-- (.) = (Prelude..)+--+-- class Category cat where+-- -- | the identity morphism+-- id :: cat a a+--+-- -- | morphism composition+-- (.) :: cat b c -> cat a b -> cat a c+--+-- instance Category Accessor where+-- id = Accessor id id+-- (.) = (.>)++-- | Compose accessors+(.>) :: Accessor t1 t -> Accessor t2 t1 -> Accessor t2 t+Accessor g1 m1 .> Accessor g2 m2 = Accessor (g1 . g2) (m2 . m1)++getA :: MonadState s m => Accessor s p -> m p+getA = gets . getter++getsA :: MonadState s m => Accessor s p -> (p -> a) -> m a+getsA a f = gets (f . getter a)++modifyA :: MonadState s m => Accessor s p -> (p -> p) -> m ()+modifyA a f = modify (modifier a f)++modifyAllA :: (MonadState s m, Functor f) => Accessor s (f w) -> Accessor w p -> (p -> p) -> m ()+modifyAllA a a' f = modifyA a (fmap $ modifier a' f)+++setA :: MonadState s m => Accessor s p -> p -> m ()+setA a p = modifyA a (const p)+++allA :: Traversable t => Accessor whole part -> Accessor (t whole) (t part)+allA (Accessor g m) = Accessor (fmap g) modifier'+ where modifier' mapParts wholes = distribute wholes (toList $ mapParts $ fmap g wholes)+ distribute wholes parts = fst $ runState (Traversable.mapM setOne wholes) parts+ setOne whole = do+ h' <- gets head+ modify tail+ return (m (const h') whole)++-- (#=) :: MonadState s m => Accessor s p -> p -> m ()+-- (#=) = setA++getsAndModifyA :: MonadState s m => Accessor s p -> (p -> (p,a)) -> m a+getsAndModifyA a f = do+ b <- getA a+ let (b',x) = f b+ modifyA a (const b')+ return x++
Yi/Boot.hs view
@@ -1,41 +1,74 @@+{-# LANGUAGE PatternGuards #-} module Yi.Boot where import Yi.Debug hiding (error) import Yi.Kernel +import System.Console.GetOpt+import System.Environment ( getArgs ) import System.Directory ( getHomeDirectory )+import System.FilePath import qualified GHC import qualified Packages import qualified DynFlags import qualified Module+import qualified ObjLink import Outputable import Control.Monad -import GHC.Exts ( unsafeCoerce# )+data Opts = Libdir String | Bindir String +options :: [OptDescr Opts]+options = [+ Option ['B'] ["libdir"] (ReqArg Libdir "libdir") "Path to runtime libraries",+ Option ['b'] ["bindir"] (ReqArg Bindir "bindir") "Path to runtime library binaries\n(default: libdir)"+ ] -- the path of our GHC installation-path :: FilePath-path = GHC_LIBDIR -- See Setup.hs+ghcLibdir :: FilePath+ghcLibdir = GHC_LIBDIR -- See Setup.hs +-- | All the packages Yi depends on, as Cabal sees it. (see Setup.hs)+pkgOpts :: [String]+pkgOpts = YI_PKG_OPTS+ -- | Create a suitable Yi Kernel, via a GHC session.+-- Also return the non-boot flags. initialize :: IO Kernel initialize = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do- session <- GHC.newSession GHC.Interactive (Just path)- dflags1 <- GHC.getSessionDynFlags session+ bootArgs <- getArgs+ let (bootFlags, _, _) = getOpt Permute options bootArgs+ let libdir = last $ YI_LIBDIR : [x | Libdir x <- bootFlags]+ bindir = last $ libdir : [x | Bindir x <- bootFlags]+ logPutStrLn $ "Using Yi libdir: " ++ libdir+ logPutStrLn $ "Using Yi bindir: " ++ bindir+ logPutStrLn $ "Using GHC libdir: " ++ ghcLibdir+ GHC.parseStaticFlags [] -- no static flags for now+ session <- GHC.newSession (Just ghcLibdir)+ logPutStrLn $ "Session started!"+ dflags0 <- GHC.getSessionDynFlags session+ -- see GHC's Main.hs+ let dflags1 = dflags0{ GHC.ghcMode = GHC.CompManager,+ GHC.hscTarget = GHC.HscInterpreted,+ GHC.ghcLink = GHC.LinkInMemory,+ GHC.verbosity = 1+ } home <- getHomeDirectory- (dflags1',_otherFlags) <- GHC.parseDynamicFlags dflags1 [- "-package ghc", "-fglasgow-exts", "-cpp", - "-i", -- clear the search directory (don't look in ./)- "-i" ++ home ++ "/.yi" -- We look for source files in ~/.yi--- ,"-v"- ]+ let extraflags = [ -- dubious: maybe YiConfig wants to use other pkgs: "-hide-all-packages"+ "-i" -- clear the search directory (don't look in ./)+ , "-i" ++ home ++ "/.yi" -- First, we look for source files in ~/.yi+ , "-i" ++ libdir+ , "-odir" ++ bindir+ , "-hidir" ++ bindir+ , "-cpp"+ ]+ (dflags1',_otherFlags) <- GHC.parseDynamicFlags dflags1 (pkgOpts ++ extraflags) (dflags2, packageIds) <- Packages.initPackages dflags1' logPutStrLn $ "packagesIds: " ++ (showSDocDump $ ppr $ packageIds)- GHC.setSessionDynFlags session dflags2{GHC.hscTarget=GHC.HscInterpreted}- return Kernel { + GHC.setSessionDynFlags session dflags2+ return Kernel { getSessionDynFlags = GHC.getSessionDynFlags session, setSessionDynFlags = GHC.setSessionDynFlags session, compileExpr = GHC.compileExpr session,@@ -50,44 +83,43 @@ nameToString = Outputable.showSDoc . Outputable.ppr, isLoaded = GHC.isLoaded session, mkModuleName = Module.mkModuleName,- getModuleGraph = GHC.getModuleGraph session+ getModuleGraph = GHC.getModuleGraph session,+ loadObjectFile = ObjLink.loadObj,+ libraryDirectory = libdir } ---- | Dynamically start Yi. +-- | Dynamically start Yi. startYi :: Kernel -> IO () startYi kernel = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do- result <- compileExpr kernel ("Yi.main :: Yi.Kernel -> Prelude.IO ()") + t <- (guessTarget kernel) "Yi.Main" Nothing+ (setTargets kernel) [t]+ loadAllTargets kernel+ yi <- join $ evalMono kernel ("Yi.Main.main :: Yi.Kernel.Kernel -> Prelude.IO ()") -- coerce the interpreted expression, so we check that we are not making an horrible mistake. logPutStrLn "Starting Yi!"- case result of- Nothing -> error "Could not compile Yi.main!"- Just x -> do let (x' :: Kernel -> IO ()) = unsafeCoerce# x- x' kernel- return ()+ yi kernel + setContextAfterLoadL :: GHC.Session -> IO [GHC.Module] setContextAfterLoadL session = do preludeModule <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing- yiModule <- GHC.findModule session (GHC.mkModuleName "Yi.Yi") Nothing -- this module re-exports all useful stuff. graph <- GHC.getModuleGraph session graph' <- filterM (GHC.isLoaded session . GHC.ms_mod_name) graph targets <- GHC.getTargets session let targets' = [ m | Just m <- map (findTarget graph') targets ] modules = map GHC.ms_mod targets'- context = preludeModule:yiModule:modules+ context = preludeModule:modules GHC.setContext session [] context- return context- where- findTarget ms t- = case filter (`matches` t) ms of- [] -> Nothing- (m:_) -> Just m-- summary `matches` GHC.Target (GHC.TargetModule m) _- = GHC.ms_mod_name summary == m- summary `matches` GHC.Target (GHC.TargetFile f _) _ - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'- _summary `matches` _target- = False+ return modules+ where+ findTarget ms t =+ case filter (`matches` t) ms of+ [] -> Nothing+ (m:_) -> Just m + summary `matches` GHC.Target (GHC.TargetModule m) _+ = GHC.ms_mod_name summary == m+ summary `matches` GHC.Target (GHC.TargetFile f _) _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _summary `matches` _target+ = False
+ Yi/Buffer.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- Copyright (C) 2004, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | The 'Buffer' module defines monadic editing operations over one-dimensional+-- buffers, which maintain a current /point/.++module Yi.Buffer+ ( BufferRef+ , FBuffer ( .. )+ , BufferM ( .. )+ , runBuffer+ , runBufferDummyWindow+ , keyB+ , curLn+ , sizeB+ , pointB+ , moveTo+ , lineMoveRel+ , lineUp+ , lineDown+ , newB+ , Point+ , Mark+ , BufferMode ( .. )+ , gotoLn+ , gotoLnFrom+ , offsetFromSol+ , leftB+ , rightB+ , leftN+ , rightN+ , insertN+ , insertNAt+ , insertB+ , deleteN+ , nelemsB+ , writeB+ , getfileB+ , setfileB+ , setnameB+ , deleteNAt+ , readB+ , elemsB+ , undosA+ , undoB+ , redoB+ , getMarkB+ , getSelectionMarkB+ , getMarkPointB+ , setMarkPointB+ , unsetMarkB+ , isUnchangedB+ , setSyntaxB+ , regexB+ , searchB+ , readAtB+ , getModeLine+ , getPercent+ , forgetPreferCol+ , clearUndosB+ , addOverlayB+ , getDynamicB+ , setDynamicB+ , nelemsBH+ , styleRangesB+ , Direction ( .. )+ , savingExcursionB+ , savingPointB+ , pendingUpdatesA+ , revertPendingUpdatesB+ , askWindow+ )+where++import Prelude hiding (error)+import System.FilePath+import Text.Regex.Posix.Wrap (Regex)+import Yi.Accessor+import Yi.Buffer.Implementation+import Yi.Syntax+import Yi.Undo+import Yi.Style+import Yi.Dynamic+import Yi.Window+import Control.Applicative+import Control.Monad.RWS+import Data.List (elemIndex)+++-- In addition to Buffer's text, this manages (among others):+-- * Log of updates mades+-- * Undo+data BufferMode = ReadOnly | ReadWrite++data FBuffer =+ FBuffer { name :: !String -- ^ immutable buffer name+ , bkey :: !BufferRef -- ^ immutable unique key+ , file :: !(Maybe FilePath) -- ^ maybe a filename associated with this buffer+ , undos :: !URList -- ^ undo/redo list+ , rawbuf :: !BufferImpl+ , bmode :: !BufferMode -- ^ a read-only bit+ , bufferDynamic :: !DynamicValues -- ^ dynamic components+ , preferCol :: !(Maybe Int) -- ^ prefered column to arrive at when we do a lineDown / lineUp+ ,pendingUpdates :: [Update] -- ^ updates that haven't been synched in the UI yet+ }+++rawbufA :: Accessor (FBuffer) (BufferImpl)+rawbufA = Accessor rawbuf (\f e -> e {rawbuf = f (rawbuf e)})++undosA :: Accessor (FBuffer) (URList)+undosA = Accessor undos (\f e -> e {undos = f (undos e)})++fileA :: Accessor (FBuffer) (Maybe FilePath)+fileA = Accessor file (\f e -> e {file = f (file e)})++preferColA :: Accessor (FBuffer) (Maybe Int)+preferColA = Accessor preferCol (\f e -> e {preferCol = f (preferCol e)})++bufferDynamicA :: Accessor (FBuffer) (DynamicValues)+bufferDynamicA = Accessor bufferDynamic (\f e -> e {bufferDynamic = f (bufferDynamic e)})++pendingUpdatesA :: Accessor (FBuffer) ([Update])+pendingUpdatesA = Accessor pendingUpdates (\f e -> e {pendingUpdates = f (pendingUpdates e)})+++-- | 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)++instance Applicative BufferM where+ pure = return+ af <*> ax = do+ f <- af+ x <- ax+ return (f x)++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 <- offsetFromSol+ pos <- pointB+ ln <- curLn+ p <- pointB+ s <- sizeB+ 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 +++ replicate 2 ' ' ++ pct++--+-- | Give a point, and the file size, gives us a percent string+--+getPercent :: Int -> Int -> String+getPercent a b = show p ++ "%"+ where p = ceiling ((fromIntegral a) / (fromIntegral b) * 100 :: Double) :: Int++queryBuffer :: (BufferImpl -> x) -> (BufferM x)+queryBuffer = getsA rawbufA++modifyBuffer :: (BufferImpl -> BufferImpl) -> BufferM ()+modifyBuffer = modifyA rawbufA++queryAndModify :: (BufferImpl -> (BufferImpl,x)) -> BufferM x+queryAndModify = getsAndModifyA rawbufA++-- | @addOverlayB s e sty@ overlays the style @sty@ between points @s@ and @e@+addOverlayB :: Point -> Point -> Style -> BufferM ()+addOverlayB s e sty = modifyBuffer $ addOverlayBI s e sty++-- | 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, b0, updates) = runRWS (fromBufferM f) w b+ in (a, modifier pendingUpdatesA (++ updates) b0)++-- | Execute a @BufferM@ value on a given buffer, using a dummy window. The new state of+-- the buffer is returned alongside the result of the computation.+runBufferDummyWindow :: FBuffer -> BufferM a -> (a, FBuffer)+runBufferDummyWindow b = runBuffer (dummyWindow $ bkey b) b+++-- Clear the undo list, so the changed "flag" is reset.+-- This has now been updated so that instead of clearing the undo list we+-- mark the point at which the file was saved.+clearUndosB :: BufferM ()+clearUndosB = modifyA undosA setSavedPointUR++getfileB :: BufferM (Maybe FilePath)+getfileB = gets file++setfileB :: FilePath -> BufferM ()+setfileB f = setA fileA (Just f)++setnameB :: String -> BufferM ()+setnameB s = modify (\fbuff -> fbuff { name = s })++keyB :: FBuffer -> BufferRef+keyB (FBuffer { bkey = u }) = u++isUnchangedB :: BufferM Bool+isUnchangedB = gets (isUnchangedUList . undos)+++undoRedo :: ( URList -> BufferImpl -> (BufferImpl, (URList, [Change])) ) -> BufferM ()+undoRedo f = do+ ur <- gets undos+ (ur',changes) <- queryAndModify (f ur)+ setA undosA ur'+ tell (concatMap changeUpdates changes)++undoB :: BufferM ()+undoB = undoRedo undoInteractivePoint >> undoRedo (manyUR undoUR)++redoB :: BufferM ()+redoB = undoRedo (manyUR redoUR)++-- | Create buffer named @nm@ with contents @s@+newB :: BufferRef -> String -> [Char] -> FBuffer+newB unique nm s =+ FBuffer { name = nm+ , bkey = unique+ , file = Nothing -- has name, not connected to a file+ , undos = emptyUR+ , rawbuf = newBI s+ , bmode = ReadWrite+ , preferCol = Nothing+ , bufferDynamic = emptyDV+ , pendingUpdates = []+ }++-- | Number of characters in the buffer+sizeB :: BufferM Int+sizeB = queryBuffer sizeBI++-- | Extract the current point+pointB :: BufferM Int+pointB = queryBuffer pointBI++-- | Return @n@ elems starting at @i@ of the buffer as a list+nelemsB :: Int -> Int -> BufferM [Char]+nelemsB n i = queryBuffer $ nelemsBI n i++-- | Return @n@ elems starting at @i@ of the buffer as a list+nelemsBH :: Int -> Int -> BufferM [(Char,Style)]+nelemsBH n i = queryBuffer $ nelemsBIH n i++styleRangesB :: Int -> Int -> BufferM [(Int,Style)]+styleRangesB n i = queryBuffer $ styleRangesBI n i++------------------------------------------------------------------------+-- Point based operations++-- | Move point in buffer to the given index+moveTo :: Int -> BufferM ()+moveTo x = do+ forgetPreferCol+ modifyBuffer $ moveToI x++------------------------------------------------------------------------++applyUpdate :: Update -> BufferM ()+applyUpdate update = do+ valid <- queryBuffer (isValidUpdate update)+ when valid $ do+ forgetPreferCol+ reversed <- queryAndModify (getActionB (AtomicChange update))+ modifyA undosA $ addUR 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 (reverseUpdate u bi) bi)) updates)++-- | Write an element into the buffer at the current point.+writeB :: Char -> BufferM ()+writeB c = do+ off <- pointB+ mapM_ applyUpdate [Delete off 1, Insert off [c]]++------------------------------------------------------------------------++-- | Insert the list at specified point, extending size of buffer+insertNAt :: [Char] -> Int -> BufferM ()+insertNAt cs pnt = applyUpdate (Insert pnt cs)+++-- | Insert the list at current point, extending size of buffer+insertN :: [Char] -> BufferM ()+insertN cs = do+ pnt <- pointB+ applyUpdate (Insert pnt cs)++-- | 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 :: Int -> Int -> BufferM ()+deleteNAt n pos = applyUpdate (Delete pos n)++------------------------------------------------------------------------+-- 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 Int)+searchB dir = queryBuffer . searchBI dir++-- | Set the syntax highlighting mode+setSyntaxB :: ExtHL -> BufferM ()+setSyntaxB = modifyBuffer . setSyntaxBI++-- | Return indices of next string in buffer matched by regex+regexB :: Regex -> BufferM (Maybe (Int,Int))+regexB = queryBuffer . regexBI++---------------------------------------------------------------------++-- | Set a mark in this buffer+setMarkPointB :: Mark -> Int -> BufferM ()+setMarkPointB m pos = modifyBuffer $ setMarkPointBI m pos++getMarkPointB :: Mark -> BufferM Int+getMarkPointB = queryBuffer . getMarkPointBI++unsetMarkB :: BufferM ()+unsetMarkB = modifyBuffer unsetMarkBI++getMarkB :: Maybe String -> BufferM Mark+getMarkB = queryAndModify . getMarkBI++getSelectionMarkB :: BufferM Mark+getSelectionMarkB = queryBuffer getSelectionMarkBI++-- | Move point -1+leftB :: BufferM ()+leftB = leftN 1++-- | Move cursor -n+leftN :: Int -> BufferM ()+leftN n = pointB >>= \p -> moveTo (p - n)++-- | Move cursor +1+rightB :: BufferM ()+rightB = rightN 1++-- | Move cursor +n+rightN :: Int -> BufferM ()+rightN n = pointB >>= \p -> moveTo (p + n)++-- ---------------------------------------------------------------------+-- Line based movement and friends++setPrefCol :: Maybe Int -> BufferM ()+setPrefCol = setA preferColA++-- | Move point down by @n@ lines. @n@ can be negative.+lineMoveRel :: Int -> BufferM Int+lineMoveRel n = do+ prefCol <- getA preferColA+ targetCol <- case prefCol of+ Nothing -> offsetFromSol+ Just x -> return x+ ofs <- gotoLnFrom n+ gotoLnFrom 0 -- make sure we are at the start of line.+ solPnt <- pointB+ chrs <- nelemsB targetCol solPnt+ moveTo $ solPnt + maybe targetCol id (elemIndex '\n' chrs)+ --logPutStrLn $ "lineMoveRel: targetCol = " ++ show targetCol+ 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 = do n <- sizeB+ nelemsB n 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 :: Int -> 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 n++------------------------------------------------------------------------++-- | Offset from start of line+offsetFromSol :: BufferM Int+offsetFromSol = queryBuffer offsetFromSolBI++-- | Go to line indexed from current point+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++-- | 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++-------------+-- Window++askWindow :: (Window -> a) -> BufferM a+askWindow = asks
+ Yi/Buffer/HighLevel.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- Copyright (C) 2008 JP Bernardy+module Yi.Buffer.HighLevel where++import Control.Applicative+import Control.Monad.State+import Data.Char+import Data.Dynamic++import Yi.Buffer+import Yi.Buffer.Normal+import Yi.Buffer.Region+import Yi.String+import Yi.Window+import Yi.Dynamic++-- ---------------------------------------------------------------------+-- Movement operations++-- | Move point to start of line+moveToSol :: BufferM ()+moveToSol = maybeMoveB Line Backward++-- | Move point to end of line+moveToEol :: BufferM ()+moveToEol = maybeMoveB Line Forward++-- | Move cursor to origin+topB :: BufferM ()+topB = moveTo 0++-- | Move cursor to end of buffer+botB :: BufferM ()+botB = moveTo =<< sizeB++-- | Move @x@ chars back, or to the sol, whichever is less+moveXorSol :: Int -> BufferM ()+moveXorSol x = replicateM_ x $ do c <- atSol; when (not c) leftB++-- | Move @x@ chars forward, or to the eol, whichever is less+moveXorEol :: Int -> BufferM ()+moveXorEol x = replicateM_ x $ do c <- atEol; when (not c) rightB++-- | Move to first char of next word forwards+nextWordB :: BufferM ()+nextWordB = moveB Word Forward++-- | Move to first char of next word backwards+prevWordB :: BufferM ()+prevWordB = moveB Word Backward++-- * Char-based movement actions.++-- | Move to the next occurence of @c@+nextCInc :: Char -> BufferM ()+nextCInc c = doUntilB_ ((c ==) <$> readB) rightB++-- | Move to the character before the next occurence of @c@+nextCExc :: Char -> BufferM ()+nextCExc c = nextCInc c >> leftB++-- | Move to the previous occurence of @c@+prevCInc :: Char -> BufferM ()+prevCInc c = doUntilB_ ((c ==) <$> readB) leftB++-- | Move to the character after the previous occurence of @c@+prevCExc :: Char -> BufferM ()+prevCExc c = prevCInc c >> rightB++-- | Move to first non-space character in this line+firstNonSpaceB :: BufferM ()+firstNonSpaceB = do moveToSol+ untilB_ ((||) <$> atEol <*> ((not . isSpace) <$> readB)) rightB++++++------------++-- | Move down next @n@ paragraphs+nextNParagraphs :: Int -> BufferM ()+nextNParagraphs n = replicateM_ n $ moveB Paragraph Forward++-- | Move up prev @n@ paragraphs+prevNParagraphs :: Int -> BufferM ()+prevNParagraphs n = replicateM_ n $ moveB Paragraph Backward+++-----------------------------------------------------------------------+-- Queries++-- | Return true if the current point is the start of a line+atSol :: BufferM Bool+atSol = atBoundaryB Line Backward++-- | Return true if the current point is the end of a line+atEol :: BufferM Bool+atEol = atBoundaryB Line Forward++-- | True if point at start of file+atSof :: BufferM Bool+atSof = atBoundaryB Document Backward++-- | True if point at end of file+atEof :: BufferM Bool+atEof = atBoundaryB Document Forward++-- | Get the current line and column number+getLineAndCol :: BufferM (Int, Int)+getLineAndCol = do+ lineNo <- curLn+ colNo <- offsetFromSol+ return (lineNo, colNo)++-- | Read the line the point is on+readLnB :: BufferM String+readLnB = readUnitB Line++-- | Read from point to end of line+readRestOfLnB :: BufferM String+readRestOfLnB = readRegionB =<< regionOfPartB Line Forward++--------------------------+-- Deletes++-- | Delete one character backward+bdeleteB :: BufferM ()+bdeleteB = deleteB Character Backward++-- | Delete forward whitespace or non-whitespace depending on+-- the character under point.+killWordB :: BufferM ()+killWordB = deleteB Word Forward++-- | Delete backward whitespace or non-whitespace depending on+-- the character before point.+bkillWordB :: BufferM ()+bkillWordB = deleteB Word Backward+++----------------------------------------+-- Transform operations++-- | capitalise the word under the cursor+uppercaseWordB :: BufferM ()+uppercaseWordB = transformB (map toUpper) Word Forward++-- | lowerise word under the cursor+lowercaseWordB :: BufferM ()+lowercaseWordB = transformB (map toLower) Word Forward++-- | capitalise the first letter of this word+capitaliseWordB :: BufferM ()+capitaliseWordB = transformB capitalizeFirst Word Forward+++-- | Delete to the end of line, excluding it.+deleteToEol :: BufferM ()+deleteToEol = deleteRegionB =<< regionOfPartB Line Forward++-- | Transpose two characters, (the Emacs C-t action)+swapB :: BufferM ()+swapB = do eol <- atEol+ when eol leftB+ transposeB Character Forward++-- ----------------------------------------------------+-- | Marks++-- | Set the current buffer mark+setSelectionMarkPointB :: Int -> BufferM ()+setSelectionMarkPointB pos = do m <- getSelectionMarkB; setMarkPointB m pos++-- | Get the current buffer mark+getSelectionMarkPointB :: BufferM Int+getSelectionMarkPointB = do m <- getSelectionMarkB; getMarkPointB m++-- | Exchange point & mark.+-- Maybe this is better put in Emacs\/Mg common file+exchangePointAndMarkB :: BufferM ()+exchangePointAndMarkB = do m <- getSelectionMarkPointB+ p <- pointB+ setSelectionMarkPointB p+ moveTo m++getBookmarkB :: String -> BufferM Mark+getBookmarkB nm = getMarkB (Just nm)++-- ---------------------------------------------------------------------+-- Buffer operations++data BufferFileInfo =+ BufferFileInfo { bufInfoFileName :: FilePath+ , bufInfoSize :: Int+ , bufInfoLineNo :: Int+ , bufInfoColNo :: Int+ , bufInfoCharNo :: Int+ , bufInfoPercent :: String+ , bufInfoModified :: Bool+ }++-- | File info, size in chars, line no, col num, char num, percent+bufInfoB :: BufferM BufferFileInfo+bufInfoB = do+ s <- sizeB+ p <- pointB+ m <- isUnchangedB+ l <- curLn+ c <- offsetFromSol+ nm <- gets name+ let bufInfo = BufferFileInfo { bufInfoFileName = nm+ , bufInfoSize = s+ , bufInfoLineNo = l+ , bufInfoColNo = c+ , bufInfoCharNo = p+ , bufInfoPercent = getPercent p s+ , bufInfoModified = not m+ }+ return bufInfo++-----------------------------+-- Window-related operations++-- | Scroll up 1 screen+upScreenB :: BufferM ()+upScreenB = upScreensB 1++-- | Scroll down 1 screen+downScreenB :: BufferM ()+downScreenB = downScreensB 1++-- | Scroll up n screens+upScreensB :: Int -> BufferM ()+upScreensB = moveScreenB Forward++-- | Scroll down n screens+downScreensB :: Int -> BufferM ()+downScreensB = moveScreenB Backward++moveScreenB :: Direction -> Int -> BufferM ()+moveScreenB dir n = do h <- askWindow height+ case dir of+ Forward -> gotoLnFrom (- (n * (h - 1)))+ Backward -> gotoLnFrom $ n * (h - 1)+ moveToSol++-- | Move to @n@ lines down from top of screen+downFromTosB :: Int -> BufferM ()+downFromTosB n = do+ moveTo =<< askWindow tospnt+ replicateM_ n lineDown++-- | Move to @n@ lines up from the bottom of the screen+upFromBosB :: Int -> BufferM ()+upFromBosB n = do+ moveTo =<< askWindow bospnt+ moveToSol+ replicateM_ n lineUp++-- | Move to middle line in screen+middleB :: BufferM ()+middleB = do+ w <- askWindow id+ moveTo (tospnt w)+ replicateM_ (height w `div` 2) lineDown++-- | Extend the given region to boundaries of the text unit.+-- For instance one can extend the selection to to complete lines, or+-- paragraphs.+extendRegionToBoundaries :: TextUnit -> BoundarySide -> BoundarySide -> Region -> BufferM Region+extendRegionToBoundaries unit bs1 bs2 region = do+ moveTo $ regionStart region+ genMaybeMoveB unit (Backward, bs1) Backward+ start <- pointB+ moveTo $ regionEnd region+ genMoveB unit (Forward, bs2) Forward+ stop <- pointB+ return $ mkRegion start stop++unitWiseRegion :: TextUnit -> Region -> BufferM Region+unitWiseRegion unit = extendRegionToBoundaries unit InsideBound OutsideBound+++-- TODO: either decide this is evil and contain it to Vim, or embrace it and move it to the+-- Buffer record.+newtype SelectionStyle = SelectionStyle TextUnit+ deriving (Typeable)++instance Initializable SelectionStyle where+ initial = SelectionStyle Character++-- | Get the current region boundaries+getSelectRegionB :: BufferM Region+getSelectRegionB = do+ m <- getMarkPointB =<< getSelectionMarkB+ p <- pointB+ let region = mkRegion m p+ SelectionStyle unit <- getDynamicB+ unitWiseRegion unit region+
+ Yi/Buffer/Implementation.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE PatternGuards, ExistentialQuantification #-}++-- Copyright (c) 2004-5, 7-8 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | 'Buffer' implementation, wrapping ByteString.+module Yi.Buffer.Implementation+ ( Update ( .. )+ , Point+ , Mark+ , Size+ , Direction (..)+ , BufferImpl+ , moveToI+ , applyUpdateI+ , isValidUpdate+ , pointBI+ , nelemsBI+ , sizeBI+ , curLnI+ , newBI+ , gotoLnRelI+ , offsetFromSolBI+ , searchBI+ , regexBI+ , getMarkBI+ , getMarkPointBI+ , setMarkPointBI+ , unsetMarkBI+ , getSelectionMarkBI+ , nelemsBIH+ , styleRangesBI+ , setSyntaxBI+ , addOverlayBI+ , inBounds+)+where++import Yi.Syntax++import qualified Data.Map as M+import Yi.Style++import Control.Monad+import Control.Arrow (second)++import Text.Regex.Base+import Text.Regex.Posix++import qualified Yi.FingerString as F+import Yi.FingerString (FingerString)+import qualified Data.ByteString.Char8 as B++import Data.Array+import Data.Maybe+++-- | Direction of movement inside a buffer+data Direction = Backward+ | Forward+ deriving Eq++type Point = Int+type Size = Int++newtype Mark = Mark {markId::Int} deriving (Eq, Ord, Show)+pointMark, markMark :: Mark+pointMark = Mark 0 -- 'point' - the insertion point mark+markMark = Mark 1 -- 'mark' - the selection mark++data MarkValue = MarkValue {markPosition::Int, _markIsLeftBound::Bool}+ deriving (Eq, Show)++type Marks = M.Map Mark MarkValue++type BufferImpl = FBufferData++data HLState = forall a. Eq a => HLState !(Highlighter a)++-- ---------------------------------------------------------------------+--+-- | The buffer text itself is stored as ByteString.+--+-- Problems with this implementation:+-- * Does not support unicode+-- * Is not optimized (O(n) operations)+--++data FBufferData =+ FBufferData { mem :: !FingerString -- ^ buffer text+ , marks :: !Marks -- ^ Marks for this buffer+ , _markNames :: !(M.Map String Mark)+ , hlcache :: !(Maybe HLState) -- ^ syntax highlighting state+ , overlays :: ![(MarkValue, MarkValue, Style)] -- ^ list of visual overlay regions+ -- Overlays should not use Mark, but directly Point+ }+++--+-- | Mutation actions (from the undo or redo list)+--+-- We use the /partial checkpoint/ (Berlage, pg16) strategy to store+-- just the components of the state that change.+--++data Update = Insert {updatePoint :: !Point, insertUpdateString :: !String} -- FIXME: use ByteString+ | Delete {updatePoint :: !Point, deleteUpdateSize :: !Size}+ deriving Show+++--------------------------------------------------+-- Low-level primitives.++-- | New FBuffer filled from string.+newBI :: String -> FBufferData+newBI s = FBufferData (F.fromString s) mks M.empty Nothing []+ where+ mks = M.fromList [(pointMark, MarkValue 0 pointLeftBound)]++-- | read @n@ chars from buffer @b@, starting at @i@+readChars :: FingerString -> Int -> Int -> FingerString+readChars p n i = F.take n $ F.drop i $ p+{-# INLINE readChars #-}++-- | Write string into buffer.+insertChars :: FingerString -> FingerString -> Int -> FingerString+insertChars p cs i = left `F.append` cs `F.append` right+ where (left,right) = F.splitAt i p+{-# INLINE insertChars #-}+++-- | Write string into buffer.+deleteChars :: FingerString -> Int -> Int -> FingerString+deleteChars p i n = left `F.append` right+ where (left,rest) = F.splitAt i p+ right = F.drop n rest+{-# INLINE deleteChars #-}++-- | calculate whether a move is in bounds.+-- Note that one can move to 1 char past the end of the buffer.+inBounds :: Int -> Int -> Int+inBounds i end | i <= 0 = 0+ | i > end = max 0 end+ | otherwise = i+{-# INLINE inBounds #-}++------------------------------------------------------------------------+-- Mid-level insert/delete++shiftMarkValue :: Point -> Size -> MarkValue -> MarkValue+shiftMarkValue from by (MarkValue p leftBound) = MarkValue shifted leftBound+ where shifted | p < from = p+ | p == from = if leftBound then p else p'+ | otherwise {- p > from -} = p'+ where p' = max from (p + by)+++mapOvlMarks :: (a -> b) -> (a, a, v) -> (b, b, v)+mapOvlMarks f (s,e,v) = (f s, f e, v)++-------------------------------------+-- * "high-level" (exported) operations++-- | Number of characters in the buffer+sizeBI :: BufferImpl -> Int+sizeBI (FBufferData p _ _ _ _) = F.length p++-- | Extract the current point+pointBI :: BufferImpl -> Int+pointBI (FBufferData _ mks _ _ _) = markPosition (mks M.! pointMark)+{-# INLINE pointBI #-}++-- | Return @n@ elems starting at @i@ of the buffer as a list+nelemsBI :: Int -> Int -> BufferImpl -> String+nelemsBI n i (FBufferData b _ _ _ _) =+ let i' = inBounds i (F.length b)+ n' = min (F.length b - i') n+ in F.toString $ readChars b n' i'+++-- | Add a style "overlay" between the given points.+addOverlayBI :: Point -> Point -> Style -> BufferImpl -> BufferImpl+addOverlayBI s e sty fb =+ let sm = MarkValue s True+ em = MarkValue e False+ in fb{overlays=(sm,em,sty) : overlays fb}++-- | Return @n@ elems starting at @i@ of the buffer as a list.+-- This routine also does syntax highlighting and applies overlays.+nelemsBIH :: Int -> Int -> BufferImpl -> [(Char,Style)]+nelemsBIH n i fb = helper i defaultStyle (styleRangesBI n i fb) (nelemsBI n i fb)+ where+ helper _ sty [] cs = setSty sty cs+ helper pos sty ((end,sty'):xs) cs = setSty sty left ++ helper end sty' xs right+ where (left, right) = splitAt (end - pos) cs+ setSty sty cs = [(c,sty) | c <- cs]++-- | Return style information for the range of @n@ characters starting+-- at @i@. Style information is derived from syntax highlighting and+-- active overlays.+-- The returned list contains tuples (@p@,@s@) where every tuple is to+-- be interpreted as apply the style @s@ from position @p@ in the buffer.+-- In the final element @p@ = @n@ + @i@.+styleRangesBI :: Int -> Int -> BufferImpl -> [(Int, Style)]+styleRangesBI n i fb = fun fb+ where+ -- The first case is to handle when no 'Highlighter a' has+ -- been assigned to the buffer (via eg 'setSyntaxBI bi "haskell"')+ fun bd@(FBufferData b _ _ Nothing _) =+ let e = F.length b+ i' = inBounds i e+ n' = min (e-i') n+ cas = [(0, defaultStyle),(e, defaultStyle)]+ in cutRanges n' i' (overlay bd cas)+ -- in this, second, case 'hl' will be bound to a 'Highlighter a'+ -- eg Yi.Syntax.Haskell.highlighter (see Yi.Syntax for defn of Highlighter) which+ -- uses '(Data.ByteString.Char8.ByteString, Int)' as its parameterized state+ fun bd@(FBufferData b _ _ (Just (HLState hl)) _) =++ let (finst,colors_) = hlColorize hl (F.toLazyByteString b) (hlStartState hl)+ colors = colors_ ++ hlColorizeEOF hl finst+ in cutRanges n i (overlay bd (makeRanges 0 colors))++ -- The parser produces a list of token sizes, convert them to buffer indices+ makeRanges :: Int -> [(Int,Style)] -> [(Int, Style)]+ makeRanges o [] = [(o,defaultStyle)]+ makeRanges o ((m,c):cs) = (o, c):makeRanges (o + m) cs++ -- Split the range list so that all split points less then x+ -- is in the left and all greater or equal in the right.+ -- Insert a new switch at x if there is none. If the new+ -- switch is left of existing switches, use a as default attribute+ splitRangesDefault :: a -> Int -> [(Int, a)] -> ([(Int, a)], [(Int, a)])+ splitRangesDefault a x [] = ([], [(x,a)])+ splitRangesDefault a x ((y,b):ys) =+ case x `compare` y of+ LT -> ([], (x,a):(y,b):ys)+ EQ -> ([], (y,b):ys)+ GT -> let (ls, rs) = splitRangesDefault b x ys in ((y,b):ls, rs)++ splitRanges :: Int -> [(Int, Style)] -> ([(Int, Style)], [(Int, Style)])+ splitRanges = splitRangesDefault defaultStyle++ cutRanges :: Int -> Int -> [(Int, Style)] -> [(Int, Style)]+ cutRanges m j = takeRanges (j+m) . snd . splitRanges j+ where takeRanges k xs = let (ls, r:_) = splitRanges k xs in ls ++ [r]++ overlayRanges :: Int -> Int -> Style -> [(Int, Style)] -> [(Int, Style)]+ overlayRanges l h a rs = left ++ adjusted ++ right+ where+ (left, rest) = splitRanges l rs+ (center, right) = splitRanges h rest+ adjusted = fmap (\(m,b) -> (m, attrOver a b)) center+++ overlay :: FBufferData -> [(Int, Style)] -> [(Int, Style)]+ overlay bd rs =+ foldr (\(sm, em, a) -> overlayRanges (markPosition sm) (markPosition em) a) rs (overlays bd)++ --attrOver att1 att2 = att1 .|. (att2 .&. 0xFFFF0000) -- Overwrite colors, keep attrs (bold, underline etc)+ attrOver att1 _att2 = att1 -- Until Vty exposes interface for attr merging....+++------------------------------------------------------------------------+-- Point based editing++-- | Move point in buffer to the given index+moveToI :: Int -> BufferImpl -> BufferImpl+moveToI i (FBufferData ptr mks nms hl ov) =+ FBufferData ptr (M.insert pointMark (MarkValue (inBounds i end) pointLeftBound) mks) nms hl ov+ where end = F.length ptr+{-# INLINE moveToI #-}++-- | Checks if an Update is valid+isValidUpdate :: Update -> BufferImpl -> Bool+isValidUpdate u b = case u of+ (Delete p n) -> check p && check (p + n)+ (Insert p _) -> check p+ where check x = x >= 0 && x <= F.length (mem b)+++-- | Apply a /valid/ update+applyUpdateI :: Update -> BufferImpl -> BufferImpl+applyUpdateI u (FBufferData p mks nms hl ov) = FBufferData p' (M.map shift mks) nms hl (map (mapOvlMarks shift) ov)+ where (p', amount) = case u of+ Insert pnt cs -> (insertChars p (F.fromString cs) pnt, length cs)+ Delete pnt len -> (deleteChars p pnt len, negate len)+ shift = shiftMarkValue (updatePoint u) amount+ -- FIXME: remove collapsed overlays++------------------------------------------------------------------------+-- Line based editing++curLnI :: BufferImpl -> Int+curLnI fb@(FBufferData ptr _ _ _ _) = 1 + F.count '\n' (F.take (pointBI fb) ptr)++-- | Go to line number @n@, relatively from this line. @0@ will go to+-- the start of this line. Returns the actual line difference we went+-- to (which may be not be the requested one, if it was out of range)+gotoLnRelI :: Int -> BufferImpl -> (BufferImpl, Int)+gotoLnRelI n fb = (moveToI np fb, max 1 n')+ where+ s = mem fb+ point = pointBI fb+ (n', np) = if n <= 0+ then+ let lineStarts = map (+1) ((F.elemIndicesEnd '\n') (F.take point s)) ++ [0]+ findLine acc _ [x] = (acc, x)+ findLine acc 0 (x:_) = (acc, x)+ findLine acc l (_:xs) = findLine (acc - 1) (l + 1) xs+ findLine _ _ [] =+ error "lineStarts ends with 0 : ... this cannot happen"+ in findLine 0 n lineStarts+ else+ let lineStarts = map (+1) ((F.elemIndices '\n') (F.drop point s))+ findLine acc _ [] = (acc, 0) -- try to go forward, but there is no such line.+ findLine acc _ [x] = (acc + 1, x)+ findLine acc 1 (x:_) = (acc, x)+ findLine acc l (_:xs) = findLine (acc + 1) (l - 1) xs+ in second (point +) (findLine 0 n lineStarts)++-- | Return index of next string in buffer that matches argument+searchBI :: Direction -> String -> BufferImpl -> Maybe Int+searchBI dir s fb@(FBufferData ptr _ _ _ _) = case dir of+ Forward -> fmap (+ pnt) $ F.findSubstring (B.pack s) $ F.drop pnt ptr+ Backward -> listToMaybe $ reverse $ F.findSubstrings (B.pack s) $ F.take (pnt + length s) ptr+ where pnt = pointBI fb -- pnt == current point++offsetFromSolBI :: BufferImpl -> Int+offsetFromSolBI fb@(FBufferData ptr _ _ _ _) = pnt - maybe 0 (1 +) (F.elemIndexEnd '\n' (F.take pnt ptr))+ where pnt = pointBI fb+++-- | Return indices of next string in buffer matched by regex+regexBI :: Regex -> BufferImpl -> Maybe (Int,Int)+regexBI re fb@(FBufferData ptr _ _ _ _) =+ let p = pointBI fb+ mmatch = matchOnce re (F.toByteString $ F.drop p ptr)+ in case mmatch of+ Just arr | ((off,len):_) <- elems arr -> Just (p+off,p+off+len)+ _ -> Nothing++getSelectionMarkBI :: BufferImpl -> Mark+getSelectionMarkBI _ = markMark -- FIXME: simplify this.++-- | Returns ths position of the 'point' mark if the requested mark is unknown (or unset)+getMarkPointBI :: Mark -> BufferImpl -> Point+getMarkPointBI m fb = markPosition (getMark fb m)++getMark :: BufferImpl -> Mark -> MarkValue+getMark (FBufferData { marks = marksMap } ) m = M.findWithDefault (marksMap M.! pointMark) m marksMap+ -- We look up mark m in the marks, the default value to return+ -- if mark m is not set, is the pointMark++-- | Set a mark point+setMarkPointBI :: Mark -> Point -> BufferImpl -> BufferImpl+setMarkPointBI m pos fb = fb {marks = M.insert m (MarkValue pos (if m == markMark then markLeftBound else False)) (marks fb)}++{-+ We must allow the unsetting of this mark, this will have the property+ that the point will always be returned as the mark.+-}+unsetMarkBI :: BufferImpl -> BufferImpl+unsetMarkBI fb = fb { marks = (M.delete markMark (marks fb)) }++-- Formerly the highlighters table was directly used+-- 'Yi.Syntax.Table.highlighters'. However avoiding to depends on all+-- highlighters implementation speed up compilation a lot when working on a+-- syntax highlighter.+setSyntaxBI :: ExtHL -> BufferImpl -> BufferImpl+setSyntaxBI (ExtHL e) fb = fb { hlcache = HLState `fmap` e }++pointLeftBound, markLeftBound :: Bool+pointLeftBound = False+markLeftBound = True++------------------------------------------------------------------------++-- | Returns the requested mark, creating a new mark with that name (at point) if needed+getMarkBI :: Maybe String -> BufferImpl -> (BufferImpl, Mark)+getMarkBI name b = getMarkDefaultPosBI name (pointBI b) b++-- | Returns the requested mark, creating a new mark with that name (at the supplied position) if needed+getMarkDefaultPosBI :: Maybe String -> Int -> BufferImpl -> (BufferImpl, Mark)+getMarkDefaultPosBI name defaultPos fb@(FBufferData ptr mks nms hl ov) =+ case flip M.lookup nms =<< name of+ Just m' -> (fb, m')+ Nothing ->+ let newMark = Mark (1 + max 1 (markId $ fst (M.findMax mks)))+ nms' = case name of+ Nothing -> nms+ Just nm -> M.insert nm newMark nms+ mks' = M.insert newMark (MarkValue defaultPos False) mks+ in (FBufferData ptr mks' nms' hl ov, newMark)++
+ Yi/Buffer/Normal.hs view
@@ -0,0 +1,254 @@+--+-- Copyright (C) 2008 JP Bernardy+--++-- | A normalized API to many buffer operations.++-- The idea is that most operations should be parametric in both+-- * the textual units they work on+-- * the direction towards which they operate (if applicable)++module Yi.Buffer.Normal (TextUnit(..), + moveB, maybeMoveB,+ transformB, transposeB,+ peekB, regionOfB, regionOfPartB, readUnitB,+ untilB, doUntilB_, untilB_,+ atBoundaryB,+ numberOfB,+ deleteB, genMaybeMoveB,+ genMoveB, BoundarySide(..), genAtBoundaryB+ ) where++import Yi.Buffer+import Yi.Buffer.Region+import Data.Char+import Control.Applicative+import Control.Monad++-- | Designate a given "unit" of text.+data TextUnit = Character+ | Word+ | 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 to characters at the same column number)+ | Paragraph+ | Document+ | GenUnit {genEnclosingUnit :: TextUnit,+ genUnitBoundary :: Direction -> BufferM Bool}+ -- (haddock, stay away) | Page | Searched++isWordChar :: Char -> Bool+isWordChar = isAlpha++isNl :: Char -> Bool+isNl = (== '\n')+++-- | Verifies that the list matches all the predicates, pairwise.+checks :: [a -> Bool] -> [a] -> Bool+checks [] _ = True+checks _ [] = False+checks (p:ps) (x:xs) = p x && checks ps xs++-- | read some characters in the specified direction, for boundary testing purposes+peekB :: Direction -> Int -> Int -> BufferM String+peekB dir siz ofs =+ do p <- pointB+ rev dir <$> nelemsB siz (p + dirOfs)+ where+ dirOfs = case dir of+ Forward -> ofs+ Backward -> 0 - siz - ofs++checkPeekB :: Int -> [Char -> Bool] -> Direction -> BufferM Bool+checkPeekB offset conds dir = checks conds <$> peekB dir (length conds) offset++-- | reverse if Backward+rev :: Direction -> [a] -> [a]+rev Forward = id+rev Backward = reverse++-- | Is the point at a @Unit@ boundary in the specified @Direction@?+atBoundary :: TextUnit -> Direction -> BufferM Bool+atBoundary Document Backward = (== 0) <$> pointB+atBoundary Document Forward = (>=) <$> pointB <*> sizeB+atBoundary Character _ = return True+atBoundary VLine _ = return True -- a fallacy; this needs a little refactoring.+atBoundary Word direction =+ checkPeekB (-1) [isWordChar, not . isWordChar] direction+atBoundary ViWord direction = do+ ~cs@[c1,c2] <- peekB direction 2 (-1)+ return (length cs /= 2 || (not (isSpace c1) && (charType c1 /= charType c2)))+ where charType c | isSpace c = 1::Int+ | isAlpha c = 2+ | otherwise = 3+atBoundary Line direction = checkPeekB 0 [isNl] direction+atBoundary Paragraph direction =+ checkPeekB (-2) [not . isNl, isNl, isNl] direction+atBoundary (GenUnit _ atBound) dir = atBound dir++enclosingUnit :: TextUnit -> TextUnit+enclosingUnit (GenUnit enclosing _) = enclosing+enclosingUnit _ = Document ++atBoundaryB :: TextUnit -> Direction -> BufferM Bool+atBoundaryB Document d = atBoundary Document d+atBoundaryB u d = (||) <$> atBoundary u d <*> atBoundaryB (enclosingUnit u) d++++-- | @genUnitBoundary u d s@ returns whether the point is at a given boundary @(d,s)@ .+-- Boundary @(d,s)@ , taking Word as example, means:+-- Word +-- ^^ ^^+-- 12 34+-- 1: (Backward,Outside)+-- 2: (Backward,Inside)+-- 3: (Forward,Inside)+-- 4: (Forward,Outside)+genAtBoundaryB :: TextUnit -> Direction -> BoundarySide -> BufferM Bool+genAtBoundaryB u d s = withOffset (off u d s) $ atBoundaryB u d+ where withOffset 0 f = f+ withOffset ofs f = savingPointB (((ofs +) <$> pointB) >>= moveTo >> f)+ off _ Backward InsideBound = 0+ off _ Backward OutsideBound = 1+ off _ Forward InsideBound = 1+ off _ Forward OutsideBound = 0++++numberOfB :: TextUnit -> TextUnit -> BufferM Int+numberOfB unit containingUnit = savingPointB $ do+ maybeMoveB containingUnit Backward+ start <- pointB+ moveB containingUnit Forward+ end <- pointB+ moveTo start+ length <$> untilB ((>= end) <$> pointB) (moveB unit Forward)++-- | Repeat an action until the condition is fulfilled or the cursor stops moving.+-- The Action may be performed zero times.+untilB :: BufferM Bool -> BufferM a -> BufferM [a]+untilB cond f = do+ stop <- cond+ if stop then return [] else doUntilB cond f++-- | Repeat an action until the condition is fulfilled or the cursor stops moving.+-- The Action is performed at least once.+doUntilB :: BufferM Bool -> BufferM a -> BufferM [a]+doUntilB cond f = loop+ where loop = do+ p <- pointB+ x <- f+ p' <- pointB+ stop <- cond+ (x:) <$> if (p /= p' && not stop) + then loop+ else return []++doUntilB_ :: BufferM Bool -> BufferM a -> BufferM ()+doUntilB_ cond f = doUntilB cond f >> return () -- maybe do an optimized version?++untilB_ :: BufferM Bool -> BufferM a -> BufferM ()+untilB_ cond f = untilB cond f >> return () -- maybe do an optimized version?+++-- | Boundary side+data BoundarySide = InsideBound | OutsideBound++-- | Generic move operation+-- Warning: moving To the (OutsideBound, Backward) bound of Document is impossible (offset -1!)+-- @genMoveB u b d@: move in direction d until encountering boundary b or unit u. See 'genAtBoundaryB' for boundary explanation.+genMoveB :: TextUnit -> (Direction, BoundarySide) -> Direction -> BufferM ()+genMoveB Character _ Forward = rightB+genMoveB Character _ Backward = leftB+genMoveB VLine _ Forward = + do ofs <- lineMoveRel 1+ when (ofs < 1) (maybeMoveB Line Forward)+genMoveB VLine _ Backward = lineUp+genMoveB unit (boundDir, boundSide) moveDir = + doUntilB_ (genAtBoundaryB unit boundDir boundSide) (moveB Character moveDir)+ +-- | Generic maybe move operation.+-- As genMoveB, but don't move if we are at boundary already.+genMaybeMoveB :: TextUnit -> (Direction, BoundarySide) -> Direction -> BufferM ()+genMaybeMoveB unit (boundDir, boundSide) moveDir =+ untilB_ (genAtBoundaryB unit boundDir boundSide) (moveB Character moveDir)+++-- | Move to the next unit boundary+moveB :: TextUnit -> Direction -> BufferM ()+moveB u d = genMoveB u (d, case d of Forward -> OutsideBound; Backward -> InsideBound) d+++-- | As 'moveB', unless the point is at a unit boundary++-- So for example here moveToEol = maybeMoveB Line Forward;+-- in that it will move to the end of current line and nowhere if we+-- are already at the end of the current line. Similarly for moveToSol.++maybeMoveB :: TextUnit -> Direction -> BufferM ()+maybeMoveB u d = genMaybeMoveB u (d, case d of Forward -> OutsideBound; Backward -> InsideBound) d++transposeB :: TextUnit -> Direction -> BufferM ()+transposeB unit direction = do+ moveB unit (opposite direction)+ w0 <- pointB+ moveB unit direction+ w0' <- pointB+ moveB unit direction+ w1' <- pointB+ moveB unit (opposite direction)+ w1 <- pointB+ swapRegionsB (mkRegion w0 w0') (mkRegion w1 w1')+ moveTo w1'++transformB :: (String -> String) -> TextUnit -> Direction -> BufferM ()+transformB f unit direction = do+ p <- pointB+ moveB unit direction+ q <- pointB+ let r = mkRegion p q+ replaceRegionB r =<< f <$> readRegionB r++-- | delete between point and next unit boundary, return the deleted region+-- TODO: save in the kill ring. (?)+deleteB :: TextUnit -> Direction -> BufferM ()+deleteB unit dir = deleteRegionB =<< regionOfPartNonEmptyB unit dir++indexAfterB :: BufferM a -> BufferM Point+indexAfterB f = savingPointB (f >> pointB)++-- | Region of the whole textunit where the current point is+regionOfB :: TextUnit -> BufferM Region+regionOfB unit = mkRegion+ <$> indexAfterB (maybeMoveB unit Backward)+ <*> indexAfterB (maybeMoveB unit Forward)++-- | 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++-- | 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+++readUnitB :: TextUnit -> BufferM String+readUnitB unit = readRegionB =<< regionOfB unit++opposite :: Direction -> Direction+opposite Backward = Forward+opposite Forward = Backward++
+ Yi/Buffer/Region.hs view
@@ -0,0 +1,56 @@+-- This module defines the Region ADT++module Yi.Buffer.Region (Region, mkRegion, mkVimRegion, regionStart, regionEnd,+ swapRegionsB, deleteRegionB, replaceRegionB, readRegionB, mapRegionB,+ inRegion) where++import Yi.Buffer++-- | The region data type. +--The region is semi open: it includes the start but not the end bound. This allows simpler region-manipulation algorithms.+-- Invariant : regionStart r <= regionEnd r+data Region = Region {regionStart, regionEnd :: !Point} ++-- | Construct a region from its bounds, vim style:+-- the right bound in included.+mkVimRegion :: Point -> Point -> Region+mkVimRegion x y = if x < y then Region x (y+1) else Region y (x+1)+++-- | Construct a region from its bounds, emacs style:+-- the right bound is excluded+mkRegion :: Point -> Point -> Region+mkRegion x y = if x < y then Region x y else Region y x+++-- | Delete an arbitrary part of the buffer+deleteRegionB :: Region -> BufferM ()+deleteRegionB r = deleteNAt (regionEnd r - regionStart r) (regionStart r)++-- | Read an arbitrary part of the buffer+readRegionB :: Region -> BufferM String+readRegionB r = nelemsB (regionEnd r - i) i+ where i = regionStart r++replaceRegionB :: Region -> String -> BufferM ()+replaceRegionB r s = savingPointB $ do+ deleteRegionB r+ insertNAt s (regionStart r)++mapRegionB :: Region -> (Char -> Char) -> BufferM ()+mapRegionB r f = do+ text <- readRegionB r+ replaceRegionB r (map f text)++-- | swap the content of two Regions+swapRegionsB :: Region -> Region -> BufferM () +swapRegionsB r r'+ | regionStart r > regionStart r' = swapRegionsB r' r+ | otherwise = do w0 <- readRegionB r+ w1 <- readRegionB r'+ replaceRegionB r' w0+ replaceRegionB r w1++-- | True if the given point is inside the given region.+inRegion :: Point -> Region -> Bool+p `inRegion` (Region start stop) = start <= p && p < stop
+ Yi/Char.hs view
@@ -0,0 +1,85 @@+--+-- Copyright (c) 2005 Tuomo Valkonen+--+--++--+-- | Same character classification and remapping routines.+--++module Yi.Char ( upcaseCtrl+ , lowcaseCtrl+ , upcaseLowcase+ , ctrlLowcase+ , lowcaseUpcase+ , ctrlUpcase+ , validChar+ , remapChar+ , remapBS+ , isDel+ , isEnter+ , setMeta, clrMeta, isMeta, metaBit+ ) where++import Yi.Event ( keyBackspace )+import Data.Char+import Data.Bits++validChar :: Char -> Bool+validChar '\n' = True+validChar '\r' = True+validChar c | isControl c = False+validChar _ = True++-- Remap a sequence of keys to another sequence.+remapChar :: Char -> Char -> Char -> Char -> Char -> Char+remapChar a1 b1 a2 _ c+ | a1 <= c && c <= b1 = chr $ ord c - ord a1 + ord a2+ | otherwise = c++upcaseCtrl, lowcaseCtrl :: Char -> Char+upcaseLowcase, ctrlLowcase :: Char -> Char+lowcaseUpcase, ctrlUpcase :: Char -> Char+upcaseCtrl = remapChar '\^A' '\^Z' 'A' 'Z'+lowcaseCtrl = remapChar '\^A' '\^Z' 'a' 'z'+upcaseLowcase = remapChar 'a' 'z' 'A' 'Z'+ctrlLowcase = remapChar 'a' 'z' '\^A' '\^Z'+lowcaseUpcase = remapChar 'A' 'Z' 'a' 'z'+ctrlUpcase = remapChar 'A' 'Z' '\^A' '\^Z'++remapBS :: Char -> Char+remapBS k | isDel k = '\BS'+ | otherwise = k++isDel :: Char -> Bool+isDel '\BS' = True+isDel '\127' = True+isDel c | c == keyBackspace = True+isDel _ = False++isEnter :: Char -> Bool+isEnter '\n' = True+isEnter '\r' = True+isEnter _ = False++-- ---------------------------------------------------------------------+--+-- If Bit 7 is set in Char, then treat as a META key (ESC)+-- This is useful as it avoids the ncurses timeout issues associated+-- with the real ESC.++-- set the meta bit, as if Mod1/Alt had been pressed+setMeta :: Char -> Char+setMeta c = chr (setBit (ord c) metaBit)++-- remove the meta bit+clrMeta :: Char -> Char+clrMeta c = chr (clearBit (ord c) metaBit)++isMeta :: Char -> Bool+isMeta c = testBit (ord c) metaBit++metaBit :: Int+metaBit = 7++
+ Yi/Completion.hs view
@@ -0,0 +1,42 @@+-- Copyright (C) 2008 JP Bernardy+++module Yi.Completion (completeInList) where++import Yi.Editor+import Data.List++-------------------------------------------+-- General completion+-------------------------------------------+commonPrefix :: [String] -> String+commonPrefix [] = []+commonPrefix strings+ | any null strings = []+ | all (== prefix) heads = prefix : commonPrefix tailz+ | otherwise = []+ where+ (heads, tailz) = unzip [(h,t) | (h:t) <- strings]+ prefix = head heads+-- for an alternative implementation see GHC's InteractiveUI module.++++completeInList :: String -> (String -> Bool) -> [ String ] -> EditorM String+completeInList s condition l+ | null filtered = printMsg "No match" >> return s+ | prefix /= s = return prefix+ | isSingleton filtered = printMsg "Sole completion" >> return s+ | prefix `elem` filtered = printMsg ("Complete, but not unique: " ++ show filtered) >> return s+ | otherwise = printMsg ("Matches: " ++ show filtered) >> return s+ where+ prefix = commonPrefix filtered+ filtered = nub $ filter condition l++ -- Not really necessary but a bit faster than @(length l) == 1@+ isSingleton :: [ a ] -> Bool+ isSingleton [_] = True+ isSingleton _ = False+++
+ Yi/Core.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE PatternSignatures #-}++-- Copyright (c) Tuomo Valkonen 2004.+-- Copyright (c) Don Stewart 2004-5. http://www.cse.unsw.edu.au/~dons++--+-- | The core actions of yi. This module is the link between the editor+-- and the UI. Key bindings, and libraries should manipulate Yi through+-- the interface defined here.++module Yi.Core (+ module Yi.Dynamic,+ -- * Keymap+ module Yi.Keymap,++ -- * Construction and destruction+ StartConfig ( .. ), -- Must be passed as the first argument to 'startEditor'+ startEditor, -- :: StartConfig -> Kernel -> Maybe Editor -> [YiM ()] -> IO ()+ quitEditor, -- :: YiM ()++#ifdef DYNAMIC+ reconfigEditor,+ loadModule,+ unloadModule,+#endif+ reloadEditor, -- :: YiM ()+ getAllNamesInScope,+ execEditorAction,++ refreshEditor, -- :: YiM ()+ suspendEditor, -- :: YiM ()++ -- * Global editor actions+ msgEditor, -- :: String -> YiM ()+ errorEditor, -- :: String -> YiM ()+ msgClr, -- :: YiM ()++ -- * Window manipulation+ closeWindow, -- :: YiM ()++ -- * Interacting with external commands+ runProcessWithInput, -- :: String -> String -> YiM String++ -- * Misc+ changeKeymap,+ runAction+ ) where++import Prelude hiding (error, sequence_, mapM_, elem, concat, all)++import Yi.Debug+import Yi.Undo+import Yi.Buffer+import Yi.Dynamic+import Yi.String+import Yi.Process ( popen )+import Yi.Editor+#ifdef DYNAMIC++#endif+import Yi.Event (eventToChar, Event)+import Yi.Keymap+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+import Yi.UI.Common as UI (UI)++import Data.Maybe+import qualified Data.Map as M++import Data.IORef+import Data.Foldable++import System.FilePath++import Control.Monad (when, forever)+import Control.Monad.Reader (runReaderT, ask)+import Control.Monad.Trans+import Control.Monad.Error ()+import Control.Exception+import Control.Concurrent+import Control.Concurrent.Chan+import Yi.Kernel++#ifdef DYNAMIC++import Data.List (notElem, delete)+import qualified ErrUtils+import qualified GHC+import qualified SrcLoc+import Outputable++#endif++-- | Make an action suitable for an interactive run.+-- UI will be refreshed.+interactive :: Action -> YiM ()+interactive action = do+ logPutStrLn ">>> interactively"+ prepAction <- withUI UI.prepareAction+ withEditor $ do prepAction+ modifyAllA buffersA undosA (addUR InteractivePoint)+ runAction action+ withEditor $ modifyA killringA krEndCmd+ refreshEditor+ logPutStrLn "<<<"+ return ()++nilKeymap :: Keymap+nilKeymap = do c <- I.anyEvent+ write $ case eventToChar c of+ 'q' -> quitEditor+ 'r' -> reconfigEditor+ 'h' -> (configHelp >> return ())+ _ -> errorEditor $ "Keymap not defined, type 'r' to reload config, 'q' to quit, 'h' for help."+ where configHelp = withEditor $ newBufferE "*configuration help*" $ unlines $+ ["To get a standard reasonable keymap, you can run yi with either --as=vim or --as=emacs.",+ "You can also create your own ~/.yi/YiConfig.hs file,",+ "see http://haskell.org/haskellwiki/Yi#How_to_Configure_Yi for help on how to do that."]+++data StartConfig = StartConfig { startFrontEnd :: UI.UIBoot+ , startConfigFile :: FilePath+ }++-- ---------------------------------------------------------------------+-- | Start up the editor, setting any state with the user preferences+-- and file names passed in, and turning on the UI+--+startEditor :: StartConfig -> Kernel -> Maybe Editor -> [YiM ()] -> IO ()+startEditor startConfig kernel st commandLineActions = do+ let+#ifdef DYNAMIC+ yiConfigFile = startConfigFile startConfig+#endif+ uiStart = startFrontEnd startConfig++ logPutStrLn "Starting Core"++ -- restore the old state+ let initEditor = maybe emptyEditor id st+ newSt <- newIORef initEditor+ -- Setting up the 1st window is a bit tricky because most functions assume there exists a "current window"+ inCh <- newChan+ outCh :: Chan Action <- newChan+ ui <- uiStart inCh outCh initEditor makeAction+ startKm <- newIORef nilKeymap+ startModules <- newIORef ["Yi.Yi"] -- this module re-exports all useful stuff, so we want it loaded at all times.+ startThreads <- newIORef []+ keymaps <- newIORef M.empty+ let yi = Yi newSt ui startThreads inCh outCh startKm keymaps kernel startModules+ runYi f = runReaderT f yi++ runYi $ do++ withEditor $ newBufferE "*messages*" "" >> return ()++#ifdef DYNAMIC+ withKernel $ \k -> do+ dflags <- getSessionDynFlags k+ setSessionDynFlags k dflags { GHC.log_action = ghcErrorReporter yi }+ -- run user configuration+ loadModule yiConfigFile -- "YiConfig"+ runConfig+#endif++ when (isNothing st) $ do -- process options if booting for the first time+ sequence_ commandLineActions++ logPutStrLn "Starting event handler"+ let+ handler e = runYi $ errorEditor (show e)+ -- | The editor's input main loop.+ -- Read key strokes from the ui and dispatches them to the buffer with focus.+ eventLoop :: IO ()+ eventLoop = do+ let run = mapM_ (\ev -> runYi (dispatch ev)) =<< getChanContents inCh+ forever $ (handle handler run >> logPutStrLn "Dispatching loop ended")+++ -- | The editor's output main loop.+ execLoop :: IO ()+ execLoop = do+ runYi refreshEditor+ let loop = sequence_ . map runYi . map interactive =<< getChanContents outCh+ forever $ (handle handler loop >> logPutStrLn "Execing loop ended")++ t1 <- forkIO eventLoop+ t2 <- forkIO execLoop+ runYi $ modifiesRef threads (\ts -> t1 : t2 : ts)++ UI.main ui -- transfer control to UI: GTK must run in the main thread, or else it's not happy.++postActions :: [Action] -> YiM ()+postActions actions = do yi <- ask; lift $ writeList2Chan (output yi) actions++-- | Process an event by advancing the current keymap automaton an+-- execing the generated actions+dispatch :: Event -> YiM ()+dispatch ev =+ do yi <- ask+ b <- withEditor getBuffer+ bkm <- getBufferKeymap b+ defKm <- readRef (defaultKeymap yi)+ let p0 = bufferKeymapProcess bkm+ freshP = I.mkAutomaton $ bufferKeymap bkm $ defKm+ p = case p0 of+ I.End -> freshP+ I.Fail -> freshP -- TODO: output error message about unhandled input+ _ -> p0+ (actions, p') = I.processOneEvent p ev+ possibilities = I.possibleActions p'+ ambiguous = not (null possibilities) && all isJust possibilities+ logPutStrLn $ "Processing: " ++ show ev+ logPutStrLn $ "Actions posted:" ++ show actions+ logPutStrLn $ "New automation: " ++ show p'+ -- TODO: if no action is posted, accumulate the input and give feedback to the user.+ postActions actions+ when ambiguous $+ postActions [makeAction $ msgEditor "Keymap was in an ambiguous state! Resetting it."]+ modifiesRef bufferKeymaps (M.insert b bkm { bufferKeymapProcess = if ambiguous then freshP+ else p'})+++changeKeymap :: Keymap -> YiM ()+changeKeymap km = do+ modifiesRef defaultKeymap (const km)+ bs <- withEditor getBuffers+ mapM_ (restartBufferThread . bkey) bs+ return ()++-- ---------------------------------------------------------------------+-- Meta operations++-- | Quit.+quitEditor :: YiM ()+quitEditor = withUI UI.end++#ifdef DYNAMIC+loadModules :: [String] -> YiM (Bool, [String])+loadModules modules = do+ withKernel $ \kernel -> do+ targets <- mapM (\m -> guessTarget kernel m Nothing) modules+ setTargets kernel targets+ -- lift $ rts_revertCAFs -- FIXME: GHCi does this; It currently has undesired effects on logging; investigate.+ logPutStrLn $ "Loading targets..."+ result <- withKernel loadAllTargets+ loaded <- withKernel setContextAfterLoad+ ok <- case result of+ GHC.Failed -> withOtherWindow (withEditor (switchToBufferE =<< getBufferWithName "*console*")) >> return False+ _ -> return True+ let newModules = map (moduleNameString . moduleName) loaded+ writesRef editorModules newModules+ logPutStrLn $ "loadModules: " ++ show modules ++ " -> " ++ show (ok, newModules)+ return (ok, newModules)++--foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()+ -- Make it "safe", just in case++tryLoadModules :: [String] -> YiM [String]+tryLoadModules [] = return []+tryLoadModules modules = do+ (ok, newModules) <- loadModules modules+ if ok+ then return newModules+ else tryLoadModules (init modules)+ -- when failed, try to drop the most recently loaded module.+ -- We do this because GHC stops trying to load modules upon the 1st failing modules.+ -- This allows to load more modules if we ever try loading a wrong module.++-- | (Re)compile+reloadEditor :: YiM [String]+reloadEditor = tryLoadModules =<< readsRef editorModules+#endif+-- | Redraw+refreshEditor :: YiM ()+refreshEditor = do editor <- with yiEditor readRef+ withUI $ flip UI.refresh editor+ withEditor $ modifyAllA buffersA pendingUpdatesA (const [])++-- | Suspend the program+suspendEditor :: YiM ()+suspendEditor = withUI UI.suspend++------------------------------------------------------------------------++------------------------------------------------------------------------+-- | Pipe a string through an external command, returning the stdout+-- chomp any trailing newline (is this desirable?)+--+-- Todo: varients with marks?+--+runProcessWithInput :: String -> String -> YiM String+runProcessWithInput cmd inp = do+ let (f:args) = split " " cmd+ (out,_err,_) <- lift $ popen f args (Just inp)+ return (chomp "\n" out)+++------------------------------------------------------------------------++-- | Same as msgEditor, but do nothing instead of printing @()@+msgEditor' :: String -> YiM ()+msgEditor' "()" = return ()+msgEditor' s = msgEditor s++runAction :: Action -> YiM ()+runAction (YiA act) = do+ act >>= msgEditor' . show+ return ()+runAction (EditorA act) = do+ withEditor act >>= msgEditor' . show+ return ()+runAction (BufferA act) = do+ withBuffer act >>= msgEditor' . show+ return ()+++msgEditor :: String -> YiM ()+msgEditor = withEditor . printMsg++-- | Show an error on the status line and log it.+errorEditor :: String -> YiM ()+errorEditor s = do msgEditor ("error: " ++ s)+ logPutStrLn $ "errorEditor: " ++ s++-- | Clear the message line at bottom of screen+msgClr :: YiM ()+msgClr = msgEditor ""++-- | Close the current window.+-- If this is the last window open, quit the program.+closeWindow :: YiM ()+closeWindow = do+ n <- withEditor $ withWindows WS.size+ when (n == 1) quitEditor+ withEditor $ tryCloseE++#ifdef DYNAMIC++-- | Recompile and reload the user's config files+reconfigEditor :: YiM ()+reconfigEditor = reloadEditor >> runConfig++runConfig :: YiM ()+runConfig = do+ loaded <- withKernel $ \kernel -> do+ let cfgMod = mkModuleName kernel "YiConfig"+ isLoaded kernel cfgMod+ if loaded+ then do result <- withKernel $ \kernel -> evalMono kernel "YiConfig.yiMain :: Yi.Yi.YiM ()"+ case result of+ Nothing -> errorEditor "Could not run YiConfig.yiMain :: Yi.Yi.YiM ()"+ Just x -> x+ else errorEditor "YiConfig not loaded"++loadModule :: String -> YiM [String]+loadModule modul = do+ logPutStrLn $ "loadModule: " ++ modul+ ms <- readsRef editorModules+ tryLoadModules (if Data.List.notElem modul ms then ms++[modul] else ms)++unloadModule :: String -> YiM [String]+unloadModule modul = do+ ms <- readsRef editorModules+ tryLoadModules $ delete modul ms++getAllNamesInScope :: YiM [String]+getAllNamesInScope = do+ withKernel $ \k -> do+ rdrNames <- getRdrNamesInScope k+ names <- getNamesInScope k+ return $ map (nameToString k) rdrNames ++ map (nameToString k) names++ghcErrorReporter :: Yi -> GHC.Severity -> SrcLoc.SrcSpan -> Outputable.PprStyle -> ErrUtils.Message -> IO ()+ghcErrorReporter yi severity srcSpan pprStyle message =+ -- the following is written in very bad style.+ flip runReaderT yi $ do+ e <- readEditor id+ let [b] = findBufferWithName "*console*" e+ withGivenBuffer b $ savingExcursionB $ do+ moveTo =<< getMarkPointB =<< getMarkB (Just "errorInsert")+ insertN msg+ insertN "\n"+ where msg = case severity of+ GHC.SevInfo -> show (message pprStyle)+ GHC.SevFatal -> show (message pprStyle)+ _ -> show ((ErrUtils.mkLocMessage srcSpan message) pprStyle)+++-- | Run a (dynamically specified) editor command.+execEditorAction :: String -> YiM ()+execEditorAction s = do+ ghcErrorHandler $ do+ result <- withKernel $ \kernel -> do+ logPutStrLn $ "execing " ++ s+ evalMono kernel ("makeAction (" ++ s ++ ") :: Yi.Yi.Action")+ case result of+ Left err -> errorEditor err+ Right x -> do runAction x+ return ()++-- | Install some default exception handlers and run the inner computation.+ghcErrorHandler :: YiM () -> YiM ()+ghcErrorHandler inner = do+ flip catchDynE (\dyn -> do+ case dyn of+ GHC.PhaseFailed _ code -> errorEditor $ "Exitted with " ++ show code+ GHC.Interrupted -> errorEditor $ "Interrupted!"+ _ -> do errorEditor $ "GHC exeption: " ++ (show (dyn :: GHC.GhcException))++ ) $+ inner++withOtherWindow :: YiM () -> YiM ()+withOtherWindow f = do+ withEditor $ shiftOtherWindow+ f+ withEditor $ prevWinE++#else+reloadEditor, reconfigEditor :: YiM ()+reconfigEditor = msgEditor "reconfigEditor: Not supported"+reloadEditor = msgEditor "reloadEditor: Not supported"+execEditorAction :: t -> YiM ()+execEditorAction _ = msgEditor "execEditorAction: Not supported"++getAllNamesInScope :: YiM [String]+getAllNamesInScope = return []+#endif
Yi/Debug.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE ParallelListComp #-}+ module Yi.Debug (- initDebug -- :: FilePath -> IO () + initDebug -- :: FilePath -> IO () ,trace -- :: String -> a -> a ,logPutStrLn ,logError@@ -8,8 +10,9 @@ ) where import Control.Concurrent+import Control.Monad.Trans import Data.IORef-import System.IO +import System.IO import System.IO.Unsafe ( unsafePerformIO ) import System.Time @@ -17,11 +20,11 @@ dbgHandle = unsafePerformIO $ newIORef stderr -- Set the file to which debugging output should be written. Though this--- is called /init/Debug. This function should be called at most once. +-- is called /init/Debug. This function should be called at most once. -- Debugging output is sent to stderr by default (i.e., if this function -- is never called. initDebug :: FilePath -> IO ()-initDebug f = do +initDebug f = do openFile f WriteMode >>= writeIORef dbgHandle logPutStrLn "Logging initialized." @@ -36,14 +39,15 @@ error s = unsafePerformIO $ do logPutStrLn s Prelude.error s -logPutStrLn :: String -> IO ()-logPutStrLn s = do time <- toCalendarTime =<< getClockTime+logPutStrLn :: (MonadIO m) => [Char] -> m ()+logPutStrLn s = liftIO $ do+ time <- toCalendarTime =<< getClockTime tId <- myThreadId h <- readIORef dbgHandle hPutStrLn h $ calendarTimeToString time ++ " " ++ show tId ++ " " ++ s hFlush h -logError :: String -> IO ()+logError :: (MonadIO m) => String -> m () logError s = logPutStrLn $ "error: " ++ s logStream :: Show a => String -> Chan a -> IO ()
+ Yi/Dired.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Copyright (c) 2007, 2008 Ben Moseley+++-- | A Simple Dired Implementation for Yi++-- TODO+-------+-- Support Symlinks+-- Mark operations+-- - rename+-- - delete+-- - search+-- set 'bmode' in buffer - ReadOnly+-- Improve the colouring to show+-- - loaded buffers+-- - .hs files+-- - marked files+-- Fix old mod dates (> 6months) to show year+-- Fix the 'number of links' field to show actual values not just 1...+-- Automatic support for browsing .zip, .gz files etc...++module Yi.Dired (+ dired+ ,diredDir+ ,diredDirBuffer+ ,fnewE+ ) where++import Control.Monad.Trans+import Data.List+import qualified Data.Map as M+import Data.Typeable+import System.Directory+import System.FilePath+import System.Locale+import System.Posix.Files+import System.Posix.Types++import System.Posix.User+-- currently used to lookup the usernames for file owners. Any+-- suggestions on how to drop the dependency welcome.++import System.Time+import Text.Printf+import Text.Regex.Posix++import Yi.Keymap.Emacs.Keys (rebind)+import Yi.MiniBuffer (withMinibuffer)+import Control.Monad+import Yi.Buffer+import Yi.Buffer.HighLevel+import Yi.Core+import Yi.Editor+import Yi.Buffer.Region+import Yi.Style+import Yi.Syntax ( Highlighter, ExtHL(..) )+import Yi.Syntax.Table ( highlighters )++------------------------------------------------+-- | If file exists, read contents of file into a new buffer, otherwise+-- creating a new empty buffer. Replace the current window with a new+-- window onto the new buffer.+--+-- Need to clean up semantics for when buffers exist, and how to attach+-- windows to buffers.+--+fnewE :: FilePath -> YiM ()+fnewE f = do+ bufs <- withEditor getBuffers+ -- The file names associated with the list of current buffers+ let bufsWithThisFilename = filter ((== Just f) . file) bufs+ -- The names of the existing buffers+ currentBufferNames = map name bufs+ -- The new name for the buffer+ bufferName = bestNewName currentBufferNames+ b <- case bufsWithThisFilename of+ [] -> do+ fe <- lift $ doesFileExist f+ de <- lift $ doesDirectoryExist f+ newBufferForPath bufferName fe de+ _ -> return (bkey $ head bufsWithThisFilename)+ withGivenBuffer b $ setfileB f -- associate buffer with file+ withGivenBuffer b $ setSyntaxB (highlighters M.! (syntaxFromExtension $ takeExtension f))+ withEditor $ switchToBufferE b+ where+ -- 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 [] -- Create new empty buffer++ {-+ Working out the name of the syntax from the extension of+ the file. Some of these are a little questionably haskell+ relatex. For example ".x" is an alex lexer specification+ I dare say that there are other file types that use ".x"+ as the file extension.+ For now though this is probably okay given the users of+ 'yi' are mostly haskell hackers, as of yet.+ -}+ syntaxFromExtension :: String -> String+ syntaxFromExtension ".hs" = "haskell"+ syntaxFromExtension ".x" = "haskell"+ syntaxFromExtension ".lhs" = "lithaskell"+ -- haskell include files such as Yi/Syntax/alex.hsinc+ syntaxFromExtension ".hsinc" = "haskell"+ syntaxFromExtension ".cabal" = "cabal"+ syntaxFromExtension ".tex" = "latex"+ syntaxFromExtension ".sty" = "latex"+ syntaxFromExtension ".cxx" = "cplusplus"+ syntaxFromExtension ".cpp" = "cplusplus"+ syntaxFromExtension ".h" = "cplusplus"+ -- I treat c file as cpp files, most users are smart enough+ -- to allow for that.+ syntaxFromExtension ".c" = "cplusplus"+ -- pepa is a subset of srmc+ syntaxFromExtension ".pepa" = "srmc"+ syntaxFromExtension ".srmc" = "srmc"+ syntaxFromExtension _ = "none"++ -- The first argument is the buffer name+ fileToNewBuffer :: String -> FilePath -> YiM BufferRef+ fileToNewBuffer bufferName path = do+ contents <- liftIO $ readFile path+ withEditor $ stringToNewBuffer bufferName contents++ -- Given the desired buffer name, plus a list of current buffer+ -- names returns the best name for the new buffer. This will+ -- be the desired one in the case that it doesn't currently exist.+ -- Otherwise we will suffix it with <n> where n is one more than the+ -- current number of suffixed similar names.+ -- IOW if we want "file.hs" but one already exists then we'll create+ -- "file.hs<1>" but if that already exists then we'll create "file.hs<2>"+ -- and so on.+ desiredBufferName = takeFileName f+ bestNewName :: [ String ] -> String+ bestNewName currentBufferNames+ | elem desiredBufferName currentBufferNames = addSuffixBName 1+ | otherwise = desiredBufferName+ where+ addSuffixBName :: Int -> String+ addSuffixBName i+ | elem possibleName currentBufferNames = addSuffixBName (i + 1)+ | otherwise = possibleName+ where+ possibleName = concat [ desiredBufferName+ , "<"+ , show i+ , ">"+ ]+------------------------------------------------+++data DiredFileInfo = DiredFileInfo { permString :: String+ , numLinks :: Integer+ , owner :: String+ , grp :: String+ , sizeInBytes :: Integer+ , modificationTimeString :: String+ }+ deriving (Show, Eq, Typeable)++data DiredEntry = DiredFile DiredFileInfo+ | DiredDir DiredFileInfo+ | DiredSymLink DiredFileInfo String+ | DiredSocket DiredFileInfo+ | DiredBlockDevice DiredFileInfo+ | DiredCharacterDevice DiredFileInfo+ | DiredNamedPipe DiredFileInfo+ | DiredNoInfo+ deriving (Show, Eq, Typeable)++data DiredState = DiredState+ { diredPath :: FilePath -- ^ The full path to the directory being viewed+ -- FIXME Choose better data structure for Marks...+ , diredMarks :: M.Map Char [FilePath] -- ^ Map values are just leafnames, not full paths+ , diredEntries :: M.Map FilePath DiredEntry -- ^ keys are just leafnames, not full paths+ , diredFilePoints :: [(Point,Point,FilePath)] -- ^ position in the buffer where filename is+ }+ deriving (Show, Eq, Typeable)++instance Initializable DiredState where+ initial = DiredState { diredPath = ""+ , diredMarks = M.empty+ , diredEntries = M.empty+ , diredFilePoints = []+ }++diredKeymap :: Keymap -> Keymap+diredKeymap = do+ (rebind [+ ("p", write $ lineUp),+ ("n", write $ lineDown),+ ("b", write $ leftB),+ ("f", write $ rightB),+ ("m", write $ diredMark),+ ("d", write $ diredMarkDel),+ ("g", write $ diredRefresh),+ ("^", write $ diredUpDir),+ ("+", write $ diredCreateDir),+ ("RET", write $ diredLoad),+ ("SPC", write $ lineDown),+ ("BACKSP", write $ diredUnmark)+ ])++dired :: YiM ()+dired = do+ msgEditor "Dired..."+ dir <- liftIO getCurrentDirectory+ fnewE dir++diredDir :: FilePath -> YiM ()+diredDir dir = diredDirBuffer dir >> return ()++diredDirBuffer :: FilePath -> YiM BufferRef+diredDirBuffer dir = do+ b <- withEditor $ stringToNewBuffer ("dired-"++dir) ""+ withGivenBuffer b (setfileB dir) -- associate the buffer with the dir+ withEditor $ switchToBufferE b+ diredLoadNewDir dir+ setBufferKeymap b diredKeymap+ return b++diredRefresh :: YiM ()+diredRefresh = do+ -- Clear buffer+ withBuffer $ do end <- sizeB+ deleteRegionB (mkRegion 0 end)+ -- Write Header+ Just dir <- withBuffer getfileB+ withBuffer $ insertN $ dir ++ ":\n"+ p <- withBuffer pointB+ withBuffer $ (addOverlayB 0 (p-2) headStyle)+ -- Scan directory+ di <- lift $ diredScanDir dir+ let ds = DiredState { diredPath = dir+ , diredMarks = M.empty+ , diredEntries = di+ , diredFilePoints = []+ }+ withBuffer $ setDynamicB ds+ -- Display results+ dlines <- linesToDisplay+ let (strss, stys, strs) = unzip3 dlines+ strss' = transpose $ map doPadding $ transpose $ strss+ ptsList <- mapM insertDiredLine $ zip3 strss' stys strs+ withBuffer $ do setDynamicB ds{diredFilePoints=ptsList}+ moveTo p+ return ()+ where+ headStyle = Style grey defaultbg+ doPadding :: [DRStrings] -> [String]+ doPadding drs = map (pad ((maximum . map drlength) drs)) drs++ pad _n (DRPerms s) = s+ pad n (DRLinks s) = (replicate (max 0 (n - length s)) ' ') ++ s+ pad n (DROwners s) = s ++ (replicate (max 0 (n - length s)) ' ') ++ " "+ pad n (DRGroups s) = s ++ (replicate (max 0 (n - length s)) ' ')+ pad n (DRSizes s) = (replicate (max 0 (n - length s)) ' ') ++ s+ pad n (DRDates s) = (replicate (max 0 (n - length s)) ' ') ++ s+ pad _n (DRFiles s) = s -- Don't right-justify the filename++ drlength = length . undrs++-- | Returns a tuple containing the textual region (the end of) which is used for 'click' detection+-- and the FilePath of the file represented by that textual region+insertDiredLine :: ([String], Style, String) -> YiM (Point, Point, FilePath)+insertDiredLine (fields, sty, filenm) = do+ withBuffer $ insertN $ (concat $ intersperse " " fields) ++ "\n"+ p <- withBuffer pointB+ let p1 = p - length (last fields) - 1+ p2 = p - 1+ when (sty /= defaultStyle) $ withBuffer (addOverlayB p1 p2 sty)+ return (p1, p2, filenm)++data DRStrings = DRPerms {undrs :: String}+ | DRLinks {undrs :: String}+ | DROwners {undrs :: String}+ | DRGroups {undrs :: String}+ | DRSizes {undrs :: String}+ | DRDates {undrs :: String}+ | DRFiles {undrs :: String}++-- | Return a List of (prefix, fullDisplayNameIncludingSourceAndDestOfLink, style, filename)+linesToDisplay :: YiM ([([DRStrings], Style, String)])+linesToDisplay = do+ dState <- withBuffer getDynamicB+ 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], Style blue defaultbg, k)+ lineToDisplay k (DiredSymLink v s) = (l " l" v ++ [DRFiles $ k ++ " -> " ++ s], Style cyan defaultbg, k)+ lineToDisplay k (DiredSocket v) = (l " s" v ++ [DRFiles $ k], Style magenta defaultbg, k)+ lineToDisplay k (DiredCharacterDevice v) = (l " c" v ++ [DRFiles $ k], Style yellow defaultbg, k)+ lineToDisplay k (DiredBlockDevice v) = (l " b" v ++ [DRFiles $ k], Style yellow defaultbg, k)+ lineToDisplay k (DiredNamedPipe v) = (l " p" v ++ [DRFiles $ k], Style brown defaultbg, k)+ lineToDisplay k DiredNoInfo = ([DRFiles $ k ++ " : Not a file/dir/symlink"], defaultStyle, k)++ l pre v = [DRPerms $ pre ++ permString v,+ DRLinks $ printf "%4d" (numLinks v),+ DROwners $ owner v,+ DRGroups $ grp v,+ DRSizes $ printf "%8d" (sizeInBytes v),+ DRDates $ modificationTimeString v]++-- | Write the contents of the supplied directory into the current buffer in dired format+diredLoadNewDir :: FilePath -> YiM ()+diredLoadNewDir _dir = do+ withBuffer $ setSyntaxB (ExtHL (Nothing :: Maybe (Highlighter ()))) -- Colours for Dired come from overlays not syntax highlighting+ diredRefresh++-- | Return dired entries for the contents of the supplied directory+diredScanDir :: FilePath -> IO (M.Map FilePath DiredEntry)+diredScanDir dir = do+ files <- getDirectoryContents dir+ let filteredFiles = filter (not . diredOmitFile) files+ foldM (lineForFile dir) M.empty filteredFiles+ where+ lineForFile :: String -> M.Map FilePath DiredEntry -> String -> IO (M.Map FilePath DiredEntry)+ lineForFile d m f = do+ let fp = (d </> f)+ fileStatus <- getSymbolicLinkStatus fp+ dfi <- lineForFilePath fp fileStatus+ let islink = isSymbolicLink fileStatus+ linkTarget <- if islink then readSymbolicLink fp else return ""+ let de = if (isDirectory fileStatus) then (DiredDir dfi) else+ if (isRegularFile fileStatus) then (DiredFile dfi) else+ if islink then (DiredSymLink dfi linkTarget) else+ if (isSocket fileStatus) then (DiredSocket dfi) else+ if (isCharacterDevice fileStatus) then (DiredCharacterDevice dfi) else+ if (isBlockDevice fileStatus) then (DiredBlockDevice dfi) else+ if (isNamedPipe fileStatus) then (DiredNamedPipe dfi) else DiredNoInfo+ return (M.insert f de m)++ lineForFilePath :: FilePath -> FileStatus -> IO DiredFileInfo+ lineForFilePath fp fileStatus = do+ modTimeStr <- return . shortCalendarTimeToString =<< toCalendarTime (TOD (floor $ toRational $ modificationTime fileStatus) 0)+ let uid = fileOwner fileStatus+ gid = fileGroup fileStatus+ _filenm <- if (isSymbolicLink fileStatus) then+ return . ((++) (takeFileName fp ++ " -> ")) =<< readSymbolicLink fp else+ return $ takeFileName fp+ ownerEntry <- catch (getUserEntryForID uid) (\_ -> getAllUserEntries >>= return . scanForUid uid)+ groupEntry <- catch (getGroupEntryForID gid) (\_ -> getAllGroupEntries >>= return . scanForGid gid)+ let fmodeStr = (modeString . fileMode) fileStatus+ sz = toInteger $ fileSize fileStatus+ ownerStr = userName ownerEntry+ groupStr = groupName groupEntry+ numOfLinks = toInteger $ linkCount fileStatus+ return $ DiredFileInfo { permString = fmodeStr+ , numLinks = numOfLinks+ , owner = ownerStr+ , grp = groupStr+ , sizeInBytes = sz+ , modificationTimeString = modTimeStr}++ shortCalendarTimeToString :: CalendarTime -> String+ shortCalendarTimeToString = formatCalendarTime defaultTimeLocale "%b %d %H:%M"++++-- | Needed on Mac OS X 10.4+scanForUid :: UserID -> [UserEntry] -> UserEntry+scanForUid uid entries = maybe (UserEntry "?" "" uid 0 "" "" "") id (find ((== uid) . userID) entries)++-- | Needed on Mac OS X 10.4+scanForGid :: GroupID -> [GroupEntry] -> GroupEntry+scanForGid gid entries = maybe (GroupEntry "?" "" gid []) id (find ((== gid) . groupID) entries)++modeString :: FileMode -> String+modeString fm = ""+ ++ strIfSet "r" ownerReadMode+ ++ strIfSet "w" ownerWriteMode+ ++ strIfSet "x" ownerExecuteMode+ ++ strIfSet "r" groupReadMode+ ++ strIfSet "w" groupWriteMode+ ++ strIfSet "x" groupExecuteMode+ ++ strIfSet "r" otherReadMode+ ++ strIfSet "w" otherWriteMode+ ++ strIfSet "x" otherExecuteMode+ where+ strIfSet s mode = if fm == (fm `unionFileModes` mode) then s else "-"++-- Default Filter: omit files ending in '~' or '#' and also '.' and '..'.+diredOmitFile :: String -> Bool+diredOmitFile = (=~".*~$|.*#$|^\\.$|^\\..$")++diredMark :: BufferM ()+diredMark = diredMarkWithChar '*' lineDown++diredMarkDel :: BufferM ()+diredMarkDel = diredMarkWithChar 'D' lineDown++diredMarkWithChar :: Char -> BufferM () -> BufferM ()+diredMarkWithChar c mv = do+ p <- pointB+ moveToSol >> insertN [c] >> deleteN 1+ moveTo p+ mv++diredUnmark :: BufferM ()+diredUnmark = diredMarkWithChar ' ' lineUp++diredLoad :: YiM ()+diredLoad = do+ (Just dir) <- withBuffer getfileB+ (fn, de) <- fileFromPoint+ let sel = dir </> fn+ case de of+ (DiredFile _dfi) -> do+ exists <- liftIO $ doesFileExist sel+ if exists then fnewE sel else msgEditor $ sel ++ " no longer exists"+ (DiredDir _dfi) -> do+ exists <- liftIO $ doesDirectoryExist sel+ if exists then diredDir sel else msgEditor $ sel ++ " no longer exists"+ (DiredSymLink _dfi dest) -> do+ let target = if isAbsolute dest then dest else dir </> dest+ existsFile <- liftIO $ doesFileExist target+ existsDir <- liftIO $ doesDirectoryExist target+ msgEditor $ "Following link:"++target+ if existsFile then fnewE target else+ if existsDir then diredDir target else+ msgEditor $ target ++ " does not exist"+ (DiredSocket _dfi) -> do+ exists <- liftIO $ doesFileExist sel+ if exists then msgEditor ("Can't open Socket " ++ sel) else msgEditor $ sel ++ " no longer exists"+ (DiredBlockDevice _dfi) -> do+ exists <- liftIO $ doesFileExist sel+ if exists then msgEditor ("Can't open Block Device " ++ sel) else msgEditor $ sel ++ " no longer exists"+ (DiredCharacterDevice _dfi) -> do+ exists <- liftIO $ doesFileExist sel+ if exists then msgEditor ("Can't open Character Device " ++ sel) else msgEditor $ sel ++ " no longer exists"+ (DiredNamedPipe _dfi) -> do+ exists <- liftIO $ doesFileExist sel+ if exists then msgEditor ("Can't open Pipe " ++ sel) else msgEditor $ sel ++ " no longer exists"+ DiredNoInfo -> msgEditor $ "No File Info for:"++sel++-- | Extract the filename at point. NB this may fail if the buffer has been edited. Maybe use Markers instead.+fileFromPoint :: YiM (FilePath, DiredEntry)+fileFromPoint = do+ p <- withBuffer pointB+ dState <- withBuffer getDynamicB+ let (_,_,f) = head $ filter (\(_,p2,_)->p<=p2) (diredFilePoints dState)+ return (f, M.findWithDefault DiredNoInfo f $ diredEntries dState)++diredUpDir :: YiM ()+diredUpDir = do+ (Just dir) <- withBuffer getfileB+ diredDir $ takeDirectory dir++diredCreateDir :: YiM ()+diredCreateDir = do+ withMinibuffer "Create Dir:" return $ \nm -> do+ (Just dir) <- withBuffer getfileB+ let newdir = dir </> nm+ msgEditor $ "Creating "++newdir++"..."+ liftIO $ createDirectoryIfMissing True newdir+ diredRefresh+
+ Yi/Dynamic.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- Copyright (c) Jean-Philippe Bernardy 2005-2007.++module Yi.Dynamic where++import Data.Dynamic+import Data.Maybe++import Yi.Accessor+import Data.Map as M+-- ---------------------------------------------------------------------+-- | Class of values that can go in the extensible state component+--+class Typeable a => Initializable a where+ initial :: a++-- | An extensible record, indexed by type+type DynamicValues = M.Map String Dynamic+++-- | Accessor a dynamic component+dynamicValueA :: Initializable a => Accessor DynamicValues a+dynamicValueA = Accessor getDynamicValue modifyDynamicValue+ where+ modifyDynamicValue :: forall a. Initializable a => (a -> a) -> DynamicValues -> DynamicValues+ modifyDynamicValue f = flip M.alter (show $ typeOf (undefined::a)) $ \m ->+ Just $ toDyn $ f $ case m of+ Nothing -> initial+ Just x -> fromJust $ fromDynamic x++ getDynamicValue :: forall a. Initializable a => DynamicValues -> a+ getDynamicValue dv = case M.lookup (show $ typeOf (undefined::a)) dv of+ Nothing -> initial+ Just x -> fromJust $ fromDynamic x++-- | The empty record+emptyDV :: DynamicValues+emptyDV = M.empty
+ Yi/Editor.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- Copyright (c) 2004-5, 8, Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | The top level editor state, and operations on it.++module Yi.Editor++{-+ -- * Buffer only stuff+ newBufferE, -- :: String -> String -> YiM ()+ listBuffersE, -- :: YiM ()+ closeBufferE, -- :: String -> YiM ()++ -- * Buffer/Window+ closeBufferAndWindowE,+ switchToBufferE,+ switchToBufferOtherWindowE,+ switchToBufferWithNameE,+ nextBufW, -- :: YiM ()+ prevBufW, -- :: YiM ()++ -- * Basic registers+ setRegE, -- :: String -> YiM ()+ getRegE, -- :: EditorM String++ -- * Dynamically extensible state+ getDynamic,+ setDynamic,++ setWindowStyleE,-- :: UIStyle -> EditorM ()+-}++where++import Yi.Buffer ( BufferRef, FBuffer (..), BufferM, newB, runBuffer, insertN )+import Yi.Buffer.HighLevel (botB)+import Text.Regex.Posix.Wrap ( Regex )+import Yi.Style ( uiStyle, UIStyle )++import Yi.Debug+import Yi.Monad+import Yi.Accessor+import Yi.Dynamic+import Yi.KillRing+import Yi.Window+import Yi.WindowSet (WindowSet)+import qualified Yi.WindowSet as WS++import Prelude hiding (error)++import Data.List ( nub )+import qualified Data.Map as M++import Control.Monad.State+import Control.Monad.Writer+++-- | The Editor state+data Editor = Editor {+ bufferStack :: ![BufferRef] -- ^ Stack of all the buffers. Never empty;+ -- first buffer is the current one.+ ,buffers :: M.Map BufferRef FBuffer+ ,bufferRefSupply :: BufferRef++ ,windows :: WindowSet Window++ ,uistyle :: !UIStyle -- ^ ui colours+ ,dynamic :: DynamicValues -- ^ dynamic components++ ,windowfill :: !Char -- ^ char to fill empty window space with+ ,tabwidth :: !Int -- ^ width of tabs+++ -- consider make the below fields part of dynamic component+ ,statusLine :: !String+ ,yreg :: !String -- ^ yank register+ ,killring :: !Killring+ ,regex :: !(Maybe (String,Regex)) -- ^ most recent regex+ }+++bufferRefSupplyA :: Accessor Editor BufferRef+bufferRefSupplyA = Accessor bufferRefSupply (\f e -> e {bufferRefSupply = f (bufferRefSupply e)})++buffersA :: Accessor Editor (M.Map BufferRef FBuffer)+buffersA = Accessor buffers (\f e -> e {buffers = f (buffers e)})++dynamicA :: Accessor Editor DynamicValues+dynamicA = Accessor dynamic (\f e -> e {dynamic = f (dynamic e)})++windowsA :: Accessor Editor (WindowSet Window)+windowsA = Accessor windows (\f e -> e {windows = f (windows e)})++killringA :: Accessor Editor Killring+killringA = Accessor killring (\f e -> e {killring = f (killring e)})+++dynA :: Initializable a => Accessor Editor a+dynA = dynamicValueA .> dynamicA++-- | The initial state+emptyEditor :: Editor+emptyEditor = Editor {+ buffers = M.singleton (bkey buf) buf+ ,windows = WS.new (dummyWindow $ bkey buf)+ ,bufferStack = [bkey buf]+ ,bufferRefSupply = 1+ ,windowfill = ' '+ ,tabwidth = 8+ ,yreg = []+ ,regex = Nothing+ ,uistyle = Yi.Style.uiStyle+ ,dynamic = M.empty+ ,statusLine = ""+ ,killring = krEmpty+ }+ where buf = newB 0 "*console*" ""++-- ---------------------------------------------------------------------++runEditor :: EditorM a -> Editor -> (a, Editor)+runEditor = runState . fromEditorM++-- ---------------------------------------------------------------------+-- Buffer operations++newBufferRef :: EditorM BufferRef+newBufferRef = do+ modifyA bufferRefSupplyA (+ 1)+ getA bufferRefSupplyA++-- | Create and fill a new buffer, using contents of string.+stringToNewBuffer :: String -- ^ The buffer name (*not* the associated file)+ -> String -- ^ The contents with which to populate the buffer+ -> EditorM BufferRef+stringToNewBuffer nm cs = do+ u <- newBufferRef+ insertBuffer (newB u nm cs)++insertBuffer :: FBuffer -> EditorM BufferRef+insertBuffer b = getsAndModify $+ \e -> (e { bufferStack = nub $ (bkey b : bufferStack e),+ buffers = M.insert (bkey b) b (buffers e)+ }, bkey b)++deleteBuffer :: BufferRef -> EditorM ()+deleteBuffer k = do+ bs <- gets bufferStack+ when (length bs > 1) $ do -- never delete the last buffer.+ modify $ \e -> e { bufferStack = filter (k /=) $ bufferStack e,+ buffers = M.delete k (buffers e)+ }++-- | Return the buffers we have+getBuffers :: EditorM [FBuffer]+getBuffers = gets (M.elems . buffers)++-- | Find buffer with this key+findBufferWith :: BufferRef -> Editor -> FBuffer+findBufferWith k e =+ case M.lookup k (buffers e) of+ Just b -> b+ Nothing -> error "Editor.findBufferWith: no buffer has this key"++-- | Find buffer with this name+findBufferWithName :: String -> Editor -> [BufferRef]+findBufferWithName n e = map bkey $ filter (\b -> name b == n) (M.elems $ buffers e)++-- | Find buffer with given name. Fail if not found.+getBufferWithName :: String -> EditorM BufferRef+getBufferWithName bufName = do+ bs <- gets $ findBufferWithName bufName+ case bs of+ [] -> fail ("Buffer not found: " ++ bufName)+ (b:_) -> return b+++------------------------------------------------------------------------++-- | Return the next buffer+nextBuffer :: EditorM BufferRef+nextBuffer = shiftBuffer 1++-- | Return the prev buffer+prevBuffer :: EditorM BufferRef+prevBuffer = shiftBuffer (negate 1)++-- | Return the buffer using a function applied to the current window's+-- buffer's index.+shiftBuffer :: Int -> EditorM BufferRef+shiftBuffer shift = gets $ \e ->+ let bs = bufferStack e+ n = shift `mod` length bs+ in (bs !! n)++------------------------------------------------------------------------++-- | Perform action with any given buffer+withGivenBuffer0 :: BufferRef -> BufferM a -> EditorM a+withGivenBuffer0 k f = withGivenBufferAndWindow0 (dummyWindow k) k f++-- | Perform action with any given buffer+withGivenBufferAndWindow0 :: Window -> BufferRef -> BufferM a -> EditorM a+withGivenBufferAndWindow0 w k f = getsAndModify $ \e ->+ let b = findBufferWith k e+ (v, b') = runBuffer w b f+ in (e {buffers = M.adjust (const b') k (buffers e)},v)+++-- | Perform action with current window's buffer+withBuffer0 :: BufferM a -> EditorM a+withBuffer0 f = do+ w <- getA (WS.currentA .> windowsA)+ withGivenBufferAndWindow0 w (bufkey w) f++-- | Return the current buffer+getBuffer :: EditorM BufferRef+getBuffer = gets (head . bufferStack)++-- | Set the current buffer+setBuffer :: BufferRef -> EditorM BufferRef+setBuffer k = do+ b <- gets $ findBufferWith k+ insertBuffer b -- a bit of a hack.++-- ---------------------------------------------------------------------++newtype EditorM a = EditorM {fromEditorM :: State Editor a}+ deriving (Monad, MonadState Editor)++--------------++-- | Find buffer with given name. Raise exception if not found.+getBufferWithName0 :: String -> EditorM BufferRef+getBufferWithName0 bufName = do+ bs <- gets $ findBufferWithName bufName+ case bs of+ [] -> fail ("Buffer not found: " ++ bufName)+ (b:_) -> return b+++-- | Set the cmd buffer, and draw message at bottom of screen+printMsg :: String -> EditorM ()+printMsg s = do+ modify $ \e -> e { statusLine = takeWhile (/= '\n') s }+ -- also show in the messages buffer, so we don't loose any message+ [b] <- gets $ findBufferWithName "*messages*"+ withGivenBuffer0 b $ do botB; insertN (s ++ "\n")+++-- ---------------------------------------------------------------------+-- registers (TODO these may be redundant now that it is easy to thread+-- state in key bindings, or maybe not.+--++-- | Put string into yank register+setRegE :: String -> EditorM ()+setRegE s = modify $ \e -> e { yreg = s }++-- | Return the contents of the yank register+getRegE :: EditorM String+getRegE = gets $ yreg++-- ---------------------------------------------------------------------+-- | Dynamically-extensible state components.+--+-- These hooks are used by keymaps to store values that result from+-- Actions (i.e. that restult from IO), as opposed to the pure values+-- they generate themselves, and can be stored internally.+--+-- The `dynamic' field is a type-indexed map.+--++-- | Retrieve a value from the extensible state+getDynamic :: Initializable a => EditorM a+getDynamic = getA (dynamicValueA .> dynamicA)++-- | Insert a value into the extensible state, keyed by its type+setDynamic :: Initializable a => a -> EditorM ()+setDynamic x = setA (dynamicValueA .> dynamicA) x++-- | A character to fill blank lines in windows with. Usually '~' for+-- vi-like editors, ' ' for everything else+setWindowFillE :: Char -> EditorM ()+setWindowFillE c = modify $ \e -> e { windowfill = c }++-- | Sets the window style.+setWindowStyleE :: UIStyle -> EditorM ()+setWindowStyleE sty = modify $ \e -> e { uistyle = sty }+++-- | Attach the next buffer in the buffer list+-- to the current window.+nextBufW :: EditorM ()+nextBufW = nextBuffer >>= switchToBufferE++-- | edit the previous buffer in the buffer list+prevBufW :: EditorM ()+prevBufW = prevBuffer >>= switchToBufferE++-- | Like fnewE, create a new buffer filled with the String @s@,+-- Open up a new window onto this buffer. Doesn't associate any file+-- with the buffer (unlike fnewE) and so is good for popup internal+-- buffers (like scratch)+newBufferE :: String -> String -> EditorM BufferRef+newBufferE f s = do+ b <- stringToNewBuffer f s+ switchToBufferE b+ return b++-- | Attach the specified buffer to the current window+switchToBufferE :: BufferRef -> EditorM ()+switchToBufferE b = modifyWindows (modifier WS.currentA (\w -> w {bufkey = b}))++-- | Attach the specified buffer to some other window than the current one+switchToBufferOtherWindowE :: BufferRef -> EditorM ()+switchToBufferOtherWindowE b = shiftOtherWindow >> switchToBufferE b++-- | Switch to the buffer specified as parameter. If the buffer name is empty, switch to the next buffer.+switchToBufferWithNameE :: String -> EditorM ()+switchToBufferWithNameE "" = nextBufW+switchToBufferWithNameE bufName = switchToBufferE =<< getBufferWithName bufName++-- | Return a list of all buffers, and their indicies+listBuffersE :: EditorM [(String,Int)]+listBuffersE = do+ bs <- getBuffers+ return $ zip (map name bs) [0..]++-- | Release resources associated with buffer+-- Note: close the current buffer if the empty string is given+closeBufferE :: String -> EditorM ()+closeBufferE bufName = do+ nextB <- nextBuffer+ b <- getBuffer+ b' <- if null bufName then return b else getBufferWithName bufName+ switchToBufferE nextB+ deleteBuffer b'++------------------------------------------------------------------------++-- | Close current buffer and window, unless it's the last one.+closeBufferAndWindowE :: EditorM ()+closeBufferAndWindowE = do+ deleteBuffer =<< getBuffer+ tryCloseE++-- | Rotate focus to the next window+nextWinE :: EditorM ()+nextWinE = modifyWindows WS.forward++-- | Rotate focus to the previous window+prevWinE :: EditorM ()+prevWinE = modifyWindows WS.backward++-- | Apply a function to the windowset.+modifyWindows :: (WindowSet Window -> WindowSet Window) -> EditorM ()+modifyWindows f = do+ b <- getsAndModifyA windowsA $ \ws -> let ws' = f ws in (ws', bufkey $ WS.current ws')+ -- TODO: push this fiddling with current buffer into windowsA+ setBuffer b+ return ()++withWindows :: (WindowSet Window -> a) -> EditorM a+withWindows = getsA windowsA++withWindow :: (Window -> a) -> EditorM a+withWindow f = getsA (WS.currentA .> windowsA) f++-- | Split the current window, opening a second window onto current buffer.+splitE :: EditorM ()+splitE = do+ b <- getBuffer+ modifyWindows (WS.add $ dummyWindow b)+++-- | Enlarge the current window+enlargeWinE :: EditorM ()+enlargeWinE = error "enlargeWinE: not implemented"++-- | Shrink the current window+shrinkWinE :: EditorM ()+shrinkWinE = error "shrinkWinE: not implemented"+++-- | Close the current window, unless it is the last window open.+tryCloseE :: EditorM ()+tryCloseE = modifyWindows WS.delete++-- | Make the current window the only window on the screen+closeOtherE :: EditorM ()+closeOtherE = modifyWindows WS.deleteOthers++-- | Switch focus to some other window. If none is available, create one.+shiftOtherWindow :: EditorM ()+shiftOtherWindow = do+ len <- withWindows WS.size+ when (len == 1) splitE+ nextWinE
+ Yi/Eval.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE PatternSignatures #-}++module Yi.Eval (+ -- * Eval\/Interpretation+ evalE,+ jumpToErrorE,+ consoleKeymap,+) where++import Control.Monad+import Control.Monad.Trans+import Data.Array+import Data.List+import Prelude hiding (error)+import System.Directory+import Text.Regex.Posix+import Yi.Core+import Yi.Debug+import Yi.Editor+import Yi.Kernel+import Yi.Keymap+import Yi.Interact hiding (write)+import Yi.Event+import Yi.Buffer+import Yi.Buffer.HighLevel+import Yi.Dired++#ifdef DYNAMIC++evalToStringE :: String -> YiM String+evalToStringE string = withKernel $ \kernel -> do+ result <- evalMono kernel ("show (" ++ string ++ ")")+ return $ case result of+ Left err -> err+ Right x -> x++#else+evalToStringE :: (Monad m) => a -> m a+evalToStringE = return+#endif+-- | Evaluate some text and show the result in the message line.+evalE :: String -> YiM ()+evalE s = evalToStringE s >>= msgEditor+++jumpToE :: String -> Int -> Int -> YiM ()+jumpToE filename line column = do+ bs <- readEditor $ findBufferWithName filename -- FIXME: should find by associated file-name+ case bs of+ [] -> do found <- lift $ doesFileExist filename+ if found+ then fnewE filename+ else error "file not found"+ (b:_) -> withEditor $ switchToBufferOtherWindowE b+ withBuffer $ do gotoLn line+ moveXorEol column+++parseErrorMessage :: String -> Maybe (String, Int, Int)+parseErrorMessage ln = do+ result :: (Array Int String) <- ln =~~ "^(.+):([0-9]+):([0-9]+):.*$"+ return (result!1, read (result!2), read (result!3))++parseErrorMessageB :: BufferM (String, Int, Int)+parseErrorMessageB = do+ ln <- readLnB+ let Just location = parseErrorMessage ln+ return location++jumpToErrorE :: YiM ()+jumpToErrorE = do+ (f,l,c) <- withBuffer parseErrorMessageB+ jumpToE f l c++prompt :: String+prompt = "Yi> "++takeCommand :: String -> String+takeCommand x | prompt `isPrefixOf` x = drop (length prompt) x+ | otherwise = x++consoleKeymap :: Keymap+consoleKeymap = do event (Event KEnter [])+ write $ do x <- withBuffer readLnB+ case parseErrorMessage x of+ Just (f,l,c) -> jumpToE f l c+ Nothing -> do withBuffer $ do+ p <- pointB+ botB+ p' <- pointB+ when (p /= p') $+ insertN ("\n" ++ prompt ++ takeCommand x)+ insertN "\n"+ pt <- pointB+ insertN prompt+ bm <- getBookmarkB "errorInsert"+ setMarkPointB bm pt+ execEditorAction $ takeCommand x
+ Yi/Event.hs view
@@ -0,0 +1,368 @@+module Yi.Event + (+ Event(..),+ Key(..), Modifier(..),++ -- * Key codes+ eventToChar, charToEvent,+ keyBreak, keyDown, keyUp, keyLeft, keyRight, keyHome,+ keyBackspace, keyDL, keyIL, keyDC, keyIC, keyEIC, keyClear,+ keyEOS, keyEOL, keySF, keySR, keyNPage, keyPPage, keySTab,+ keyCTab, keyCATab, keyEnter, keySReset, keyReset, keyPrint,+ keyLL, keyA1, keyA3, keyB2, keyC1, keyC3, keyBTab, keyBeg,+ keyCancel, keyClose, keyCommand, keyCopy, keyCreate, keyEnd,+ keyExit, keyFind, keyHelp, keyMark, keyMessage, keyMove, keyNext,+ keyOpen, keyOptions, keyPrevious, keyRedo, keyReference, keyRefresh,+ keyReplace, keyRestart, keyResume, keySave, keySBeg, keySCancel,+ keySCommand, keySCopy, keySCreate, keySDC, keySDL, keySelect, keySEnd,+ keySEOL, keySExit, keySFind, keySHelp, keySHome, keySIC, keySLeft,+ keySMessage, keySMove, keySNext, keySOptions, keySPrevious, keySPrint,+ keySRedo, keySReplace, keySRight, keySRsume, keySSave, keySSuspend,+ keySUndo, keySuspend, keyUndo,+ ) where++import Data.Bits+import Data.Char (chr,ord)+import Yi.Debug++data Modifier = MShift | MCtrl | MMeta+ deriving (Show,Eq,Ord)++data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns+ | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu+ | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord)++data Event = Event Key [Modifier] deriving (Show,Eq,Ord)++++-- | Map an Event to a Char. This should be gotten rid of, eventually.+-- (the vim keymap should handle event directly)+eventToChar :: Event -> Char+eventToChar (Event KBS _) = keyBackspace+eventToChar (Event KIns _) = keyIC+eventToChar (Event KHome _) = keyHome+eventToChar (Event KDel _) = keyDC+eventToChar (Event KEnd _) = keyEnd+eventToChar (Event KUp _) = keyUp+eventToChar (Event KDown _) = keyDown+eventToChar (Event KPageUp _) = keyPPage+eventToChar (Event KPageDown _) = keyNPage+eventToChar (Event KLeft _) = keyLeft+eventToChar (Event KRight _) = keyRight+eventToChar (Event KEnter _) = '\n'+eventToChar (Event KEsc _) = '\ESC'++eventToChar (Event (KASCII c) mods) = (if MMeta `elem` mods then setMeta else id) $+ (if MCtrl `elem` mods then ctrlLowcase else id) $+ c++eventToChar ev = trace ("Got event " ++ show ev) keyOops++-- | Map a Char to an Event. This should be gotten rid of, eventually.+charToEvent :: Char -> Event+charToEvent c + | c == keyBackspace = Event KBS [] + | c == keyHome = Event KHome []+ | c == keyEnd = Event KEnd []+ | c == keyUp = Event KUp []+ | c == keyDown = Event KDown []+ | c == keyPPage = Event KPageUp []+ | c == keyNPage = Event KPageDown []+ | c == keyLeft = Event KLeft []+ | c == keyRight = Event KRight []+ | c == '\n' = Event KEnter []+ | c == '\ESC' = Event KEsc [] + | ord c < 32 = Event (KASCII (lowcaseCtrl c)) [MCtrl]+ | otherwise = Event (KASCII c) []+++remapChar :: Char -> Char -> Char -> Char -> Char -> Char+remapChar a1 b1 a2 _ c+ | a1 <= c && c <= b1 = chr $ ord c - ord a1 + ord a2+ | otherwise = c++ctrlLowcase :: Char -> Char+ctrlLowcase = remapChar 'a' 'z' '\^A' '\^Z'++lowcaseCtrl :: Char -> Char+lowcaseCtrl = remapChar '\^A' '\^Z' 'a' 'z'++-- set the meta bit, as if Mod1/Alt had been pressed+setMeta :: Char -> Char+setMeta c = chr (setBit (ord c) metaBit)++metaBit :: Int+metaBit = 7+++-- | Some constants for easy symbolic manipulation.+-- See man getch(3ncurses) for semantics.++keyBreak :: Char+keyBreak = chr (257)++keyDown :: Char+keyDown = chr (258)++keyUp :: Char+keyUp = chr (259)++keyLeft :: Char+keyLeft = chr (260)++keyRight :: Char+keyRight = chr (261)++keyHome :: Char+keyHome = chr (262)++keyBackspace :: Char+keyBackspace = chr (263)++keyDL :: Char+keyDL = chr (328)++keyIL :: Char+keyIL = chr (329)++keyDC :: Char+keyDC = chr (330)++keyIC :: Char+keyIC = chr (331)++keyEIC :: Char+keyEIC = chr (332)++keyClear :: Char+keyClear = chr (333)++keyEOS :: Char+keyEOS = chr (334)++keyEOL :: Char+keyEOL = chr (335)++keySF :: Char+keySF = chr (336)++keySR :: Char+keySR = chr (337)++keyNPage :: Char+keyNPage = chr (338)++keyPPage :: Char+keyPPage = chr (339)++keySTab :: Char+keySTab = chr (340)++keyCTab :: Char+keyCTab = chr (341)++keyCATab :: Char+keyCATab = chr (342)++keyEnter :: Char+keyEnter = chr (343)++keySReset :: Char+keySReset = chr (344)++keyReset :: Char+keyReset = chr (345)++keyPrint :: Char+keyPrint = chr (346)++keyLL :: Char+keyLL = chr (347)++keyA1 :: Char+keyA1 = chr (348)++keyA3 :: Char+keyA3 = chr (349)++keyB2 :: Char+keyB2 = chr (350)++keyC1 :: Char+keyC1 = chr (351)++keyC3 :: Char+keyC3 = chr (352)++keyBTab :: Char+keyBTab = chr (353)++keyBeg :: Char+keyBeg = chr (354)++keyCancel :: Char+keyCancel = chr (355)++keyClose :: Char+keyClose = chr (356)++keyCommand :: Char+keyCommand = chr (357)++keyCopy :: Char+keyCopy = chr (358)++keyCreate :: Char+keyCreate = chr (359)++keyEnd :: Char+keyEnd = chr (360)++keyExit :: Char+keyExit = chr (361)++keyFind :: Char+keyFind = chr (362)++keyHelp :: Char+keyHelp = chr (363)++keyMark :: Char+keyMark = chr (364)++keyMessage :: Char+keyMessage = chr (365)++keyMove :: Char+keyMove = chr (366)++keyNext :: Char+keyNext = chr (367)++keyOpen :: Char+keyOpen = chr (368)++keyOptions :: Char+keyOptions = chr (369)++keyPrevious :: Char+keyPrevious = chr (370)++keyRedo :: Char+keyRedo = chr (371)++keyReference :: Char+keyReference = chr (372)++keyRefresh :: Char+keyRefresh = chr (373)++keyReplace :: Char+keyReplace = chr (374)++keyRestart :: Char+keyRestart = chr (375)++keyResume :: Char+keyResume = chr (376)++keySave :: Char+keySave = chr (377)++keySBeg :: Char+keySBeg = chr (378)++keySCancel :: Char+keySCancel = chr (379)++keySCommand :: Char+keySCommand = chr (380)++keySCopy :: Char+keySCopy = chr (381)++keySCreate :: Char+keySCreate = chr (382)++keySDC :: Char+keySDC = chr (383)++keySDL :: Char+keySDL = chr (384)++keySelect :: Char+keySelect = chr (385)++keySEnd :: Char+keySEnd = chr (386)++keySEOL :: Char+keySEOL = chr (387)++keySExit :: Char+keySExit = chr (388)++keySFind :: Char+keySFind = chr (389)++keySHelp :: Char+keySHelp = chr (390)++keySHome :: Char+keySHome = chr (391)++keySIC :: Char+keySIC = chr (392)++keySLeft :: Char+keySLeft = chr (393)++keySMessage :: Char+keySMessage = chr (394)++keySMove :: Char+keySMove = chr (395)++keySNext :: Char+keySNext = chr (396)++keySOptions :: Char+keySOptions = chr (397)++keySPrevious :: Char+keySPrevious = chr (398)++keySPrint :: Char+keySPrint = chr (399)++keySRedo :: Char+keySRedo = chr (400)++keySReplace :: Char+keySReplace = chr (401)++keySRight :: Char+keySRight = chr (402)++keySRsume :: Char+keySRsume = chr (403)++keySSave :: Char+keySSave = chr (404)++keySSuspend :: Char+keySSuspend = chr (405)++keySUndo :: Char+keySUndo = chr (406)++keySuspend :: Char+keySuspend = chr (407)++keyUndo :: Char+keyUndo = chr (408)++keyOops :: Char+keyOops = chr 0+
+ Yi/File.hs view
@@ -0,0 +1,64 @@+module Yi.File (+ -- * File-based actions+ fwriteE, -- :: YiM ()+ fwriteAllE, -- :: YiM ()+ fwriteToE, -- :: String -> YiM ()+ backupE, -- :: FilePath -> YiM ()++ -- * Buffer editing+ revertE, -- :: YiM ()+) where+++import Control.Monad.State (gets)+import Control.Monad.Trans+import Prelude hiding (error)+import System.FilePath+import Yi.Buffer+import Yi.Core+import Yi.Debug+import Yi.Keymap+++-- | Revert to the contents of the file on disk+revertE :: YiM ()+revertE = do+ mfp <- withBuffer getfileB+ case mfp of+ Just fp -> do+ s <- liftIO $ readFile fp+ withBuffer $ do+ end <- sizeB+ p <- pointB+ moveTo 0+ deleteN end+ insertN s+ moveTo p+ clearUndosB+ msgEditor ("Reverted from " ++ show fp)+ Nothing -> do+ msgEditor "Can't revert, no file associated with buffer."+ return ()++-- | Write current buffer to disk, if this buffer is associated with a file+fwriteE :: YiM ()+fwriteE = do contents <- withBuffer elemsB+ fname <- withBuffer (gets file)+ withBuffer clearUndosB+ case fname of+ Just n -> liftIO $ writeFile n contents+ Nothing -> msgEditor "Buffer not associated with a file."++-- | Write current buffer to disk as @f@. If this buffer doesn't+-- currently have a file associated with it, the file is set to @f@+fwriteToE :: String -> YiM ()+fwriteToE f = do withBuffer $ setfileB f+ fwriteE++-- | Write all open buffers+fwriteAllE :: YiM ()+fwriteAllE = error "fwriteAllE not implemented"++-- | Make a backup copy of file+backupE :: FilePath -> YiM ()+backupE = error "backupE not implemented"
+ Yi/FingerString.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE MultiParamTypeClasses #-}++-- Copyright (c) 2008 Gustav Munkby++-- | This module defines a string representation in terms of+-- | ByteStrings stored in a finger tree.+module Yi.FingerString (+ FingerString,+ fromString, fromByteString, fromLazyByteString,+ toString, toByteString, toLazyByteString,+ rebalance,+ null, head, tail, empty, take, drop, append, splitAt, count, length,+ elemIndices, findSubstring, findSubstrings, elemIndexEnd, elemIndicesEnd+) where++import Prelude hiding (null, head, tail, length, take, drop, splitAt, head, tail, foldl, reverse)+import qualified Data.List as L++import qualified Data.ByteString.Char8 as B+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as LB++import qualified Data.FingerTree as T+import Data.FingerTree hiding (null, empty)++import Data.Monoid+import Data.Foldable (toList)+import Data.Maybe (listToMaybe)++chunkSize :: Int+chunkSize = 128++data Size = Size { unSize :: Int }+data FingerString = FingerString { unFingerString :: FingerTree Size ByteString }+ deriving (Eq, Show)++(-|) :: ByteString -> FingerTree Size ByteString -> FingerTree Size ByteString+b -| t | B.null b = t+ | otherwise = b <| t++(|-) :: FingerTree Size ByteString -> ByteString -> FingerTree Size ByteString+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++toLazyByteString :: FingerString -> LB.ByteString+toLazyByteString = LB.fromChunks . toList . unFingerString++toByteString :: FingerString -> ByteString+toByteString = B.concat . toList . unFingerString++toString :: FingerString -> String+toString = LB.unpack . toLazyByteString++fromLazyByteString :: LB.ByteString -> FingerString+fromLazyByteString = FingerString . toTree+ where+ toTree b | LB.null b = T.empty+ toTree b = let (h,t) = LB.splitAt (fromIntegral chunkSize) b in+ (B.concat $ LB.toChunks h) <| toTree t++fromByteString :: ByteString -> FingerString+fromByteString = FingerString . toTree+ where+ toTree b | B.null b = T.empty+ toTree b = let (h,t) = B.splitAt chunkSize b in h <| toTree t++fromString :: String -> FingerString+fromString = FingerString . toTree+ where+ toTree [] = T.empty+ toTree b = let (h,t) = L.splitAt chunkSize b in B.pack h <| toTree t++-- | Optimize the tree, to contain equally sized substrings+rebalance :: FingerString -> FingerString+rebalance = fromLazyByteString . toLazyByteString++null :: FingerString -> Bool+null (FingerString a) = T.null a++head :: FingerString -> Char+head (FingerString a) = case T.viewl a of+ EmptyL -> error "FingerString.head: empty string"+ x :< _ -> B.head x++tail :: FingerString -> FingerString+tail (FingerString a) = case T.viewl a of+ EmptyL -> error "FingerString.tail: empty string"+ x :< r -> FingerString $ (B.tail x) -| r++empty :: FingerString+empty = FingerString T.empty++-- | Get the length of the standard string.+length :: FingerString -> Int+length = unSize . measure . unFingerString++-- | Append two strings by merging the two finger trees.+append :: FingerString -> FingerString -> FingerString+append (FingerString a) (FingerString b) = FingerString $+ case T.viewr a of+ EmptyR -> b+ l :> x -> case T.viewl b of+ EmptyL -> a+ x' :< r -> if B.length x + B.length x' < chunkSize+ then l >< singleton (x `B.append` x') >< r+ else a >< b++take, drop :: Int -> FingerString -> FingerString+take n = fst . splitAt n+drop n = snd . splitAt n++-- | Split the string at the specified position.+splitAt :: Int -> FingerString -> (FingerString, FingerString)+splitAt n (FingerString t) =+ case T.viewl c of+ x :< r | n' /= 0 ->+ let (lx, rx) = B.splitAt n' x in (FingerString $ l |- lx, FingerString $ rx -| r)+ _ -> (FingerString l, FingerString c)+ where+ (l, c) = T.split ((> n) . unSize) t+ n' = n - unSize (measure l)++-- | Count the number of occurrences of the specified character.+count :: Char -> FingerString -> Int+count x = fromIntegral . LB.count x . toLazyByteString++-- | Get the last index of the specified character+elemIndexEnd :: Char -> FingerString -> Maybe Int+elemIndexEnd x = listToMaybe . elemIndicesEnd x++-- | Get all indices of the specified character, in reverse order.+-- This function has good lazy behaviour: taking the head of the resulting list is O(1)+elemIndicesEnd :: Char -> FingerString -> [Int]+elemIndicesEnd x = treeEIE . unFingerString+ where+ treeEIE :: FingerTree Size ByteString -> [Int]+ treeEIE t = case T.viewr t of+ l :> s -> fmap (+ unSize (measure l)) (L.reverse (B.elemIndices x s)) ++ treeEIE l+ EmptyR -> []++-- | Get all indices of the specified character+-- This function has good lazy behaviour: taking the head of the resulting list is O(1)+elemIndices :: Char -> FingerString -> [Int]+elemIndices x = map fromIntegral . LB.elemIndices x . toLazyByteString++-- | Determine the first index of the ByteString in the buffer.+findSubstring :: ByteString -> FingerString -> Maybe Int+findSubstring x = listToMaybe . findSubstrings x++-- | Determine the indices of the given ByteString in the buffer.+findSubstrings :: ByteString -> FingerString -> [Int]+findSubstrings x m = [i | i <- elemIndices (B.head x) m, x `isPrefixOf` drop i m]++-- | Determine whether the ByteString is a prefix of the buffer.+isPrefixOf :: ByteString -> FingerString -> Bool+isPrefixOf x = LB.isPrefixOf (LB.fromChunks [x]) . toLazyByteString
+ Yi/History.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE PatternSignatures, DeriveDataTypeable #-}++-- Copyright (c) 2005,2007,2008 Jean-Philippe Bernardy++-- "command history" implementation++module Yi.History where++import Yi.Buffer+import Data.Char+import Data.List+import Data.Dynamic+import Yi.Dynamic+import Yi.Editor+import Yi.Accessor++data History = History {_historyCurrent :: Int,+ _historyContents :: [String]}++ deriving (Show, Typeable)+instance Initializable History where+ initial = (History (-1) [])+++historyUp :: EditorM ()+historyUp = historyMove 1++historyDown :: EditorM ()+historyDown = historyMove (-1)++historyStart :: EditorM ()+historyStart = do+ (History _cur cont) <- getA dynA+ setA dynA (History 0 (nub ("":cont)))+ debugHist++historyFinish :: EditorM ()+historyFinish = do+ (History _cur cont) <- getA dynA+ curValue <- withBuffer0 elemsB+ setA dynA $ History (-1) (nub $ dropWhile null $ (curValue:cont))++-- TODO: scrap+debugHist :: EditorM ()+debugHist = return ()++historyMove :: Int -> EditorM ()+historyMove delta = do+ (History cur cont) <- getA dynA+ curValue <- withBuffer0 elemsB+ let len = length cont+ next = cur + delta+ nextValue = cont !! next+ case (next < 0, next >= len) of+ (True, _) -> printMsg "end of history, no next item."+ (_, True) -> printMsg "beginning of history, no previous item."+ (_,_) -> do+ setA dynA (History next (take cur cont ++ [curValue] ++ drop (cur+1) cont))+ debugHist+ withBuffer0 $ do+ sz <- sizeB+ moveTo 0+ deleteN sz+ insertN nextValue+
+ Yi/Indent.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Handles indentation in the keymaps. Includes:+-- * (TODO) Auto-indentation to the previous lines indentation+-- * Tab-expansion+-- * Shifting of the indentation for a region of text++module Yi.Indent where++import Control.Monad++import Yi.Buffer+import Yi.Buffer.HighLevel+-- import Yi.Debug+import Yi.Dynamic++import Yi.Buffer.Region++import Data.Char+import Data.Typeable+import Data.List++{- 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+ , tabSize :: Int+ , shiftWidth :: Int+ }+ deriving (Eq, Show, Typeable)++{- The default indent settings should likely be initializable from a global+ - preference.+ - Currently the initial settings reflect what's usually used in Yi's sources.+ - One aspect that is common in Yi that is not covered is that the first+ - indent is usually 4 spaces instead of 2.+ -}+instance Initializable IndentSettings where+ initial = IndentSettings True 2 2++{- Inserts either a \t or the number of spaces specified by tabSize in the+ - IndentSettings+ -}+insertTabB :: BufferM ()+insertTabB = do+ indentSettings <- indentSettingsB+ insertN $ if expandTabs indentSettings+ then replicate (tabSize indentSettings) ' '+ else ['\t']++indentSettingsB :: BufferM IndentSettings+indentSettingsB = getDynamicB++getPreviousLineB :: BufferM String+getPreviousLineB =+ savingExcursionB $ do+ lineUp+ readLnB++fetchPreviousIndentsB :: BufferM [Int]+fetchPreviousIndentsB = do+ p0 <- pointB+ lineUp+ p1 <- pointB+ l <- readLnB+ i <- indentOfB l+ if p0 == p1 || i == 0 then return [0] else do+ is <- fetchPreviousIndentsB+ return (i:is)++cycleIndentsB :: [Int] -> BufferM ()+cycleIndentsB indents = do+ l <- readLnB+ curIndent <- indentOfB l+ let (below, above) = span (< curIndent) $ indents+ -- msgEditor $ show (below, above)+ indentToB $ last (above ++ below)++autoIndentB :: BufferM ()+autoIndentB = do+ is <- savingExcursionB fetchPreviousIndentsB+ pl <- getPreviousLineB+ pli <- indentOfB pl+ let i = lastOpenBracket pl+ indents = pli+2 : i : is+ cycleIndentsB $ sort $ nub indents+++-- returns the position of the last opening bracket+-- (where bracket is parens, braces or curly braces)+-- on the given line, if there is one.+lastOpenBracket :: String -> Int+lastOpenBracket s =+ -- The 'max' is really here because if there is no opening+ -- bracket in then 'afterLastOpen' is the whole line and+ -- consequently 'fromEnd + 1' is one more than the whole+ -- of the line.+ max 0 indentation+ where+ indentation = (length s) - (fromEnd + 1)+ fromEnd = length afterLastOpen+ afterLastOpen = takeWhile (not . isOpening) $ reverse s++ isOpening :: Char -> Bool+ isOpening '(' = True+ isOpening '[' = True+ isOpening '{' = True+ isOpening _ = False++indentOfB :: String -> BufferM Int+indentOfB = spacingOfB . takeWhile isSpace++spacingOfB :: String -> BufferM Int+spacingOfB text = do+ indentSettings <- indentSettingsB+ let spacingOfChar '\t' = tabSize indentSettings+ spacingOfChar _ = 1+ return $ sum $ map spacingOfChar text++indentToB :: Int -> BufferM ()+indentToB level = do+ l <- readLnB+ cur <- offsetFromSol+ moveToSol+ deleteToEol+ let (curIndent, restOfLine) = span isSpace l+ origOffsetFromIndent = cur - (length curIndent)+ newFromEol = if origOffsetFromIndent <= 0+ then length restOfLine+ else (length restOfLine - origOffsetFromIndent)+ insertN (replicate level ' ' ++ restOfLine)+ leftN newFromEol++-- | Indent as much as the previous line+indentAsPreviousB :: BufferM ()+indentAsPreviousB =+ do pl <- getPreviousLineB+ pli <- indentOfB pl+ indentToB pli+++-- | shiftIndent num+-- | shifts right (or left if num is negative) num times, filling in tabs if+-- | expandTabs is set in the buffers IndentSettings+-- TODO: This uses mkVimRegion+shiftIndentOfLine :: Int -> BufferM ()+shiftIndentOfLine numOfShifts = do+ moveToSol+ sol <- pointB+ firstNonSpaceB+ -- ptOfNonSpace <- pointB+ isAtSol <- atSol+ when (not isAtSol) leftB+ ptOfLastSpace <- pointB+ -- msgEditor ("ptOfLastSpace= " ++ (show ptOfLastSpace) ++ "-" ++ (show sol) ++ "=" ++ (show (ptOfLastSpace - sol)))+ indentSettings <- indentSettingsB+ let countSpace '\t' = tabSize indentSettings+ countSpace _ = 1 -- we'll assume nothing but tabs and spaces+ cnt <- if isAtSol then return 0+ else readRegionB (mkVimRegion sol ptOfLastSpace) >>= return . sum . map countSpace+ if not isAtSol then deleteRegionB (mkVimRegion sol ptOfLastSpace)+ else return ()++ let newcount = cnt + ((shiftWidth indentSettings) * numOfShifts)+ if (newcount <= 0)+ then return ()+ else do+ let tabs = replicate (newcount `div` (tabSize indentSettings)) '\t'+ spaces = replicate (newcount `mod` (tabSize indentSettings)) ' '+ moveToSol+ insertN $ if expandTabs indentSettings then replicate newcount ' '+ else tabs ++ spaces++ firstNonSpaceB++shiftIndentOfSelection :: Int -> BufferM ()+shiftIndentOfSelection shiftCount = do+ mark <- getSelectionMarkPointB+ (row2,_) <- getLineAndCol+ moveTo mark+ (row1,_) <- getLineAndCol+ let step = if (row2 > row1)+ then lineDown+ else lineUp+ numOfLines = 1 + (abs (row2 - row1))+ replicateM_ numOfLines (shiftIndentOfLine shiftCount >> step)+
+ Yi/Interact.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE UndecidableInstances, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}++-- Copyright (c) Jean-Philippe Bernardy 2007-8++{- |+This is a library of interactive processes combinators, usable to+define extensible keymaps.++(Inspired by the Parsec library, written by Koen Claessen)++The processes are:++* composable++* extensible: it is always possible to override a behaviour by combination of+ 'adjustPriority' and '<|>'. (See also '<||' for a convenient combination of the two.)++* monadic: sequencing is done via monadic bind. (leveraging the whole+ battery of monadic tools that Haskell provides)++The processes can parse input, and write output that depends on it.++The semantics are quite obvious; only disjunction+deserve a bit more explanation:++in @p = (a '<|>' b)@, what happens if @a@ and @b@ recognize the same+input (prefix), but produce conflicting output?++* if the output is the same (as by the PEq class), then the processes (prefixes) are "merged"+* if a Write is more prioritized than the other, the one with low priority will be discarded+* otherwise, the output will be delayed until one of the branches can be discarded.+* if there is no way to disambiguate, then no output will be generated anymore. (oops!)+-}++module Yi.Interact+ (+ I, P (Fail, End),+ MonadInteract (..),+ PEq (..),+ deprioritize,+ (<||),+ comap,+ option,+ oneOf,+ processOneEvent,+ possibleActions,+ event,+ events,+ satisfy,+ choice,+ mkAutomaton,+ runWrite+ ) where++import Control.Applicative+import Control.Arrow (first)+import Control.Monad.State hiding ( get )+import Data.List (nubBy)++------------------------------------------------+-- Classes++class PEq a where+ equiv :: a -> a -> Bool++-- | Abstraction of monadic interactive processes+class (PEq w, Monad m, Alternative m, Applicative m, MonadPlus m) => MonadInteract m w e | m -> w e where+ write :: w -> m ()+ -- ^ Outputs a result.+ anyEvent :: m e+ -- ^ Consumes and returns the next character.+ -- Fails if there is no input left.+ adjustPriority :: Int -> m a -> m a+++-------------------------------------------------+-- State transformation++-- Needs -fallow-undecidable-instances+instance MonadInteract m w e => MonadInteract (StateT s m) w e where+ write = lift . write+ anyEvent = lift anyEvent+ adjustPriority p (StateT f) = StateT (\s -> adjustPriority p (f s))++instance (MonadInteract m w e) => Alternative (StateT s m) where+ empty = mzero+ (<|>) = mplus++instance MonadInteract m w e => Applicative (StateT s m) where+ pure = return+ a <*> b = do f <- a; x <- b; return (f x)+++---------------------------------------------------------------------------+-- | Interactive process description+data I ev w a where+ Returns :: a -> I ev w a+ Binds :: I ev w a -> (a -> I ev w b) -> I ev w b+ Gets :: I ev w ev+ Fails :: I ev w a+ Writes :: Int -> w -> I ev w ()+ Plus :: I ev w a -> I ev w a -> I ev w a++++-- | Cofunctor on the the event parameter. This can be used to convert+-- from a specific event type to a general one. (e.g. from+-- full-fleged events to chars)++comap :: (ev1 -> ev2) -> I ev2 m a -> I ev1 m a+comap _f (Returns a) = Returns a+comap f Gets = fmap f Gets+comap f (Binds a b) = Binds (comap f a) (comap f . b)+comap _f Fails = Fails+comap _f (Writes p w) = Writes p w+comap f (Plus a b) = Plus (comap f a) (comap f b)++instance Functor (I event w) where+ fmap f i = pure f <*> i++instance Applicative (I ev w) where+ pure = return+ a <*> b = do f <- a; x <- b; return (f x)++instance Alternative (I ev w) where+ empty = Fails+ (<|>) = Plus++instance Monad (I event w) where+ return = Returns+ fail _ = Fails+ (>>=) = Binds++instance PEq w => MonadPlus (I event w) where+ mzero = Fails+ mplus = Plus++instance PEq w => MonadInteract (I event w) w event where+ write = Writes 0+ anyEvent = Gets+ adjustPriority dp i = case i of+ Returns x -> Returns x+ Binds x f -> Binds (adjustPriority dp x) (\y -> adjustPriority dp (f y))+ Gets -> Gets+ Fails -> Fails+ Writes p w -> Writes (p + dp) w+ Plus a b -> Plus (adjustPriority dp a) (adjustPriority dp b)+++++infixl 3 <||++deprioritize :: (MonadInteract f w e) => f a -> f a+deprioritize = adjustPriority 1++(<||) :: (MonadInteract f w e) => f a -> f a -> f a+a <|| b = a <|> (adjustPriority 1 b)++++-- | Convert a process description to an "executable" process.+mkProcess :: PEq w => I ev w a -> ((a -> P ev w) -> P ev w)+mkProcess (Returns x) = \fut -> fut x+mkProcess Fails = (\_fut -> Fail)+mkProcess (m `Binds` f) = \fut -> (mkProcess m) (\a -> mkProcess (f a) fut)+mkProcess Gets = Get+mkProcess (Writes prior w) = \fut -> Write prior w (fut ())+mkProcess (Plus a b) = \fut -> Best (mkProcess a fut) (mkProcess b fut)+++----------------------------------------------------------------------+-- Process type++-- | Operational representation of a process+data P event w+ = Get (event -> P event w)+ | Fail+ | Write Int w (P event w) -- low numbers indicate high priority+ | Best (P event w) (P event w)+ | End++-- ---------------------------------------------------------------------------+-- Operations over P++runWrite :: PEq w => P event w -> [event] -> [w]+runWrite _ [] = []+runWrite Fail _ = []+runWrite p (c:cs) = let (ws, p') = processOneEvent p c in ws ++ runWrite p' cs++processOneEvent :: PEq w => P event w -> event -> ([w], P event w)+processOneEvent p e = pullWrites $ simplify $ pushEvent p e++pushEvent :: P ev w -> ev -> P ev w++pushEvent (Best c d) e = Best (pushEvent c e) (pushEvent d e)+pushEvent (Write p w c) e = Write p w (pushEvent c e)+pushEvent (Get f) e = f e+pushEvent Fail _ = Fail+pushEvent End _ = End++-- | Remove failing cases; fuse writes;+simplify :: PEq w => P ev w -> P ev w+simplify (Best c d) = best' c d+simplify (Write p w c) = case simplify c of+ Fail -> Fail+ c' -> Write p w c'+simplify p = p++best' :: PEq w => P ev w -> P ev w -> P ev w+best' c d = best (simplify c) (simplify d)++-- | Pull the most writes from two parallel processes; both are guaranteed not to contain any "Best"+best :: PEq w => P ev w -> P ev w -> P ev w+Write p w c `best` Write q x d+-- Prioritized write:+ | p < q = Write p w c+ | p > q = Write q x d+-- Agreeing writes:+ | equiv w x = Write p w (best' c d)+-- (Disagreeing writes will be delayed)++-- fail disappears+Fail `best` p = p+p `best` Fail = p++-- impossible to pull anything; leave Best constructor+p `best` q = Best p q++pullWrites :: P event w -> ([w], P event w)+pullWrites (Write _ w p) = first (w:) (pullWrites p)+pullWrites p = ([], p)++-- | Return the list of possible actions to write.+-- 'Nothing' indicates a read.+possibleActions :: P event w -> [Maybe w]+possibleActions = nubBy equiv' . helper+ where helper (Get _) = [Nothing]+ helper (Write _ w _) = [Just w]+ helper (Best p q) = helper p ++ helper q+ helper _ = []+ equiv' Nothing Nothing = True+ equiv' _ _ = False++instance (Show w, Show ev) => Show (P ev w) where+ show (Get _) = "?"+ show (Write prior w p) = "!" ++ show prior ++ ":" ++ show w ++ "->" ++ show p+ show (End) = "."+ show (Fail) = "*"+ show (Best p q) = "{" ++ show p ++ "|" ++ show q ++ "}"++-- ---------------------------------------------------------------------------+-- Derived operations+oneOf :: (Eq event, MonadInteract m w event) => [event] -> m event+oneOf s = satisfy (`elem` s)++satisfy :: MonadInteract m w event => (event -> Bool) -> m event+-- ^ Consumes and returns the next character, if it satisfies the+-- specified predicate.+satisfy p = do c <- anyEvent; if p c then return c else fail "not satisfy'ed"++event :: (Eq event, MonadInteract m w event) => event -> m event+-- ^ Parses and returns the specified character.+event c = satisfy (c ==)++events :: (Eq event, MonadInteract m w event) => [event] -> m [event]+-- ^ Parses and returns the specified list of events (lazily).+events = mapM event++choice :: (MonadInteract m w e) => [m a] -> m a+-- ^ Combines all parsers in the specified list.+choice [] = fail "No choice succeeds"+choice [p] = p+choice (p:ps) = p `mplus` choice ps++option :: (MonadInteract m w e) => a -> m a -> m a+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming+-- any input.+option x p = p `mplus` return x++-- runProcess :: PEq w => I event w a -> [event] -> [w]+-- -- ^ Converts a process into a function that maps input to output.+-- -- The process does not hold to the input stream (no space leak) and+-- -- produces the output as soon as possible.+-- runProcess f = runWrite (mkF f)+-- where mkF i = mkProcess i (const (Get (const Fail)))++mkAutomaton :: PEq w => I ev w a -> P ev w+mkAutomaton i = mkProcess i (const End)+++
Yi/Kernel.hs view
@@ -1,22 +1,26 @@-+{-# LANGUAGE MagicHash, Rank2Types #-} -- | This module is the interface to GHC (interpreter). It knows -- nothing about Yi (at the haskell level; it can know names of -- modules or functions as strings) -module Yi.Kernel (Kernel(..), eval, moduleName, moduleNameString, ms_mod_name) where+#ifdef DYNAMIC +module Yi.Kernel (Kernel(..), evalHValue, evalMono, moduleName, moduleNameString, ms_mod_name) where+ import Control.Monad import Outputable import qualified GHC import qualified Linker import qualified Module import qualified Packages+import GHC.Exts ( unsafeCoerce# ) --- | GHC API Kernel. +-- | GHC API Kernel. -- Calls to the GHC API must go though this type. (Because of the use "global variables" in GHC I imagine) -- ie. the simpler approach of passing just the GHC session does not work. + data Kernel = Kernel { getSessionDynFlags :: IO GHC.DynFlags,@@ -26,27 +30,37 @@ setTargets :: [GHC.Target] -> IO (), loadAllTargets :: IO GHC.SuccessFlag, findModule :: String -> IO GHC.Module,- setContext :: [GHC.Module] -- ^ entire top level scope of these modules- -> [GHC.Module] -- ^ exports only of these modules- -> IO (),+ setContext :: [GHC.Module]+ -> [GHC.Module]+ -> IO (), -- ^ entire top level scope of 1st arg modules; exports only of 2nd arg modules setContextAfterLoad :: IO [GHC.Module], getNamesInScope :: IO [GHC.Name], getRdrNamesInScope :: IO [GHC.RdrName], mkModuleName :: String -> GHC.ModuleName, isLoaded :: GHC.ModuleName -> IO Bool,- nameToString :: forall a. Outputable a => a -> String,- getModuleGraph :: IO GHC.ModuleGraph+ nameToString :: Outputable a => a -> String,+ getModuleGraph :: IO GHC.ModuleGraph,+ loadObjectFile :: String -> IO (),+ libraryDirectory :: String } --- | Dynamic evaluation-eval :: Kernel -> String -> IO GHC.HValue-eval kernel expr = do+-- | Dynamic evaluation to an HValue; fails in the monad if compilation failed.+evalHValue :: Monad m => Kernel -> String -> IO (m GHC.HValue)+evalHValue kernel expr = do result <- compileExpr kernel expr- case result of- Nothing -> error $ "Could not compile expr: " ++ expr+ return $ case result of+ Nothing -> fail $ "Could not compile: " ++ expr Just x -> return x - ++-- | Evaluate a monomorphic value dynamically. Fails in the monad if compilation failed.+evalMono :: Monad m => Kernel -> String -> IO (m a)+evalMono kernel expr = liftM (liftM (unsafeCoerce# :: GHC.HValue -> a)) (evalHValue kernel expr)++-- evalTyp :: Typeable a => Kernel -> String -> IO (m a)+++ moduleName :: GHC.Module -> GHC.ModuleName moduleName = Module.moduleName @@ -55,3 +69,10 @@ ms_mod_name :: GHC.ModSummary -> GHC.ModuleName ms_mod_name = GHC.ms_mod_name++#else++module Yi.Kernel where+data Kernel = Kernel++#endif
+ Yi/Keymap.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-}++-- Copyright (c) Jean-Philippe Bernardy 2007.++module Yi.Keymap where++import Prelude hiding (error)+import Yi.UI.Common+import qualified Yi.Editor as Editor+import Yi.Editor (EditorM, Editor, runEditor)+import qualified Data.Map as M+import Yi.Kernel+import Control.Monad.Reader+import Data.Typeable+import Data.IORef+import Control.Exception+import Control.Concurrent+import Yi.Buffer+import qualified Yi.Interact as I+import Yi.Monad+import Control.Monad.State+import Yi.Event++data Action = forall a. Show a => YiA (YiM a)+ | forall a. Show a => EditorA (EditorM a)+ | forall a. Show a => BufferA (BufferM a)+-- | InsertA String+-- | TextA Direction Unit Operation++instance I.PEq Action where+ equiv _ _ = False++instance Show Action where+ show (YiA _) = "@Y"+ show (EditorA _) = "@E"+ show (BufferA _) = "@B"++type Interact ev a = I.I ev Action a++type KeymapM a = Interact Event a++type Keymap = KeymapM ()++type KeymapEndo = Keymap -> Keymap++type KeymapProcess = I.P Event Action+++data BufferKeymap = BufferKeymap+ { bufferKeymap :: KeymapEndo -- ^ Buffer's local keymap modification+ , bufferKeymapProcess :: KeymapProcess -- ^ Current state of the keymap automaton+ }++data Yi = Yi {yiEditor :: IORef Editor,+ yiUi :: UI,+ threads :: IORef [ThreadId], -- ^ all our threads+ input :: Chan Event, -- ^ input stream+ output :: Chan Action, -- ^ output stream+ defaultKeymap :: IORef Keymap,+ bufferKeymaps :: IORef (M.Map BufferRef BufferKeymap),+ yiKernel :: Kernel,+ editorModules :: IORef [String] -- ^ modules requested by user: (e.g. ["YiConfig", "Yi.Dired"])+ }++-- | The type of user-bindable functions+type YiM = ReaderT Yi IO++-----------------------+-- Keymap basics++write :: (I.MonadInteract m Action ev, YiAction a x, Show x) => a -> m ()+write x = I.write (makeAction x)+++-----------------------+-- Keymap thread handling++setBufferKeymap :: BufferRef -> KeymapEndo -> YiM ()+setBufferKeymap b km = do+ bkm <- getBufferKeymap b+ modifiesRef bufferKeymaps (M.insert b bkm {bufferKeymap = km, bufferKeymapProcess = I.Fail})++restartBufferThread :: BufferRef -> YiM ()+restartBufferThread b = do+ bkm <- getBufferKeymap b+ modifiesRef bufferKeymaps (M.insert b bkm {bufferKeymapProcess = I.Fail})++deleteBufferKeymap :: BufferRef -> YiM ()+deleteBufferKeymap b = modifiesRef bufferKeymaps (M.delete b)++getBufferKeymap :: BufferRef -> YiM BufferKeymap+getBufferKeymap b = do+ kms <- readsRef bufferKeymaps+ return $ case M.lookup b kms of+ Just bkm -> bkm+ Nothing -> BufferKeymap {bufferKeymap = id, bufferKeymapProcess = I.Fail}++--------------------------------+-- Uninteresting glue code++withKernel :: (Kernel -> IO a) -> YiM a+withKernel = with yiKernel++withUI :: (UI -> IO a) -> YiM a+withUI = with yiUi++withUI2 :: (UI -> x -> EditorM a) -> (x -> YiM a)+withUI2 f x = do+ e <- ask+ withEditor $ f (yiUi e) x++withEditor :: EditorM a -> YiM a+withEditor f = do+ r <- asks yiEditor+ e <- readRef r+ let (a,e') = runEditor f e+ -- Make sure that the result of runEditor is evaluated before+ -- replacing the editor state. Otherwise, we might replace e+ -- with an exception-producing thunk, which makes it impossible+ -- to look at or update the editor state.+ e' `seq` a `seq` writeRef r e'+ return a++withGivenBuffer :: BufferRef -> BufferM a -> YiM a+withGivenBuffer b f = withEditor (Editor.withGivenBuffer0 b f)++withBuffer :: BufferM a -> YiM a+withBuffer f = withEditor (Editor.withBuffer0 f)++readEditor :: (Editor -> a) -> YiM a+readEditor f = withEditor (gets f)++catchDynE :: Typeable exception => YiM a -> (exception -> YiM a) -> YiM a+catchDynE inner handler = ReaderT (\r -> catchDyn (runReaderT inner r) (\e -> runReaderT (handler e) r))++catchJustE :: (Exception -> Maybe b) -- ^ Predicate to select exceptions+ -> YiM a -- ^ Computation to run+ -> (b -> YiM a) -- ^ Handler+ -> YiM a+catchJustE p c h = ReaderT (\r -> catchJust p (runReaderT c r) (\b -> runReaderT (h b) r))++handleJustE :: (Exception -> Maybe b) -> (b -> YiM a) -> YiM a -> YiM a+handleJustE p h c = catchJustE p c h++-- | Shut down all of our threads. Should free buffers etc.+shutdown :: YiM ()+shutdown = do ts <- readsRef threads+ lift $ mapM_ killThread ts++-- -------------------------------------------++class YiAction a x | a -> x where+ makeAction :: Show x => a -> Action++instance YiAction (YiM x) x where+ makeAction = YiA+++instance YiAction (EditorM x) x where+ makeAction = EditorA++instance YiAction (BufferM x) x where+ makeAction = BufferA+
+ Yi/Keymap/Completion.hs view
@@ -0,0 +1,69 @@+--+-- Copyright (c) B.Zapf July 2005+--+--++-- | This is a little helper for completion interfaces.++module Yi.Keymap.Completion (+ CompletionTree(CT),+ stepTree, obvious, mergeTrees, listToTree, complete)+ where++import Data.List++-- inside a completion tree, the a's must be unique on each level++data CompletionTree a = CT [(a,CompletionTree a)]++instance (Show a) => Show (CompletionTree a) where+ show x = show' x++show' :: (Show a) => CompletionTree a -> String+show' (CT []) = []+show' (CT [(a,st)]) = shows a $ show' st+show' (CT trees) = "["+++ (concat $+ intersperse "|" $+ map (\(x,y)->shows x $ show' y) trees)+ ++"]"++compareBy :: (Ord b) => (a->b)->a->a->Ordering+compareBy f a b = compare (f a) (f b)++listToTree :: [a] -> CompletionTree a+listToTree = foldr (\a b->CT [(a,b)]) (CT [])++stepTree :: Eq a => CompletionTree a->a->Maybe ([a],CompletionTree a)+stepTree (CT completions) letter = Just $ obvious $ CT $ filter+ ((letter==).fst) completions++obvious :: CompletionTree a -> ([a],CompletionTree a)+obvious (CT [(letter,moretrees)]) = ((\(x,y)->(letter:x,y)) $+ obvious moretrees)+obvious remainingchoice = ([],remainingchoice)++mergeTrees :: Ord a => [CompletionTree a] -> CompletionTree a+mergeTrees a = mergeTrees' (map sort' a)+ where sort' = CT.(sortBy (compareBy fst).(\(CT l)->l))++mergeTrees':: Ord a => [CompletionTree a] -> CompletionTree a+mergeTrees' trees = CT $+ map (\x->(fst $ head x,mergeTrees $ map snd x)) $+ groupBy (((EQ==).).compareBy fst) $+ sortBy (compareBy fst) $+ concat $+ map (\(CT x)->x) trees++complete :: Eq a => CompletionTree a -> [a] -> ([a],CompletionTree a)+complete tree [] = ([],tree)+complete (CT []) _ = ([],CT [])+complete (CT level) (a:ta) = (\(x,y)->(a:x,y)) $+ case match of+ Just m -> complete (snd m) ta+ Nothing -> ([],CT [])+ where match = find ((a==).fst) level+++--alternatives :: CompletionTree a->[[a]]+
+ Yi/Keymap/Ee.hs view
@@ -0,0 +1,43 @@+-- Copyright (c) 2005, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- Introductory binding for the 'ee' editor++module Yi.Keymap.Ee ( keymap ) where++import Yi.Yi+import Control.Arrow+import Yi.Keymap.Emacs.KillRing++keymap :: Keymap+keymap = comap eventToChar (command +++ insert)++-- Control keys:+-- ^a ascii code ^i tab ^r right+-- ^b bottom of text ^j newline ^t top of text+-- ^c command ^k delete char ^u up+-- ^d down ^l left ^v undelete word+-- ^e search prompt ^m newline ^w delete word+-- ^f undelete char ^n next page ^x search+-- ^g begin of line ^o end of line ^y delete line+-- ^h backspace ^p prev page ^z undelete line+-- ^[ (escape) menu++insert :: Interact Char ()+insert = do c <- satisfy (const True); write (insertN c)++command :: Interact Char ()+command = choice [event c >> write act | (c, act) <- cmds]+ where cmds = [('\^R', rightB ),+ ('\^B', botB ),+ ('\^T', topB ),+ ('\^K', deleteN 1 ),+ ('\^U', execB Move VLine Backward),+ ('\^D', execB Move VLine Forward),+ ('\^L', leftB ),+ ('\^G', moveToSol ),+ ('\^O', moveToEol ),+ ('\^Y', killLineE ),+ ('\^H', bdeleteB ),+ ('\^X', quitEditor )]++
+ Yi/Keymap/Emacs.hs view
@@ -0,0 +1,156 @@+--+-- Copyright (c) 2005,2007,2008 Jean-Philippe Bernardy+--+--++-- This module aims at a mode that should be (mostly) intuitive to+-- emacs users, but mapping things into the Yi world when+-- convenient. Hence, do not go into the trouble of trying 100%+-- emulation. For example, M-x gives access to Yi (Haskell) functions,+-- with their native names.++module Yi.Keymap.Emacs+ ( keymap+ , makeKeymap+ )+where++import Yi.Yi+import Yi.TextCompletion+import Yi.Keymap.Emacs.KillRing+import Yi.Keymap.Emacs.UnivArgument+import Yi.Keymap.Emacs.Utils+ ( KList+ , completeFileName+ , evalRegionE+ , executeExtendedCommandE+ , findFile+ , insertNextC+ , insertSelf+ , isearchKeymap+ , killBufferE+ , makeKeymap+ , queryReplaceE+ , readArgC+ , scrollDownE+ , scrollUpE+ , shellCommandE+ , switchBufferE+ , withMinibuffer+ )+import Yi.Buffer+import Yi.Buffer.Normal+import Data.Maybe++import Control.Monad+import Control.Applicative++import Yi.Indent++selfInsertKeymap :: Keymap+selfInsertKeymap = do+ Event (KASCII c) [] <- satisfy isPrintableEvent+ write (insertSelf c)+ where isPrintableEvent (Event (KASCII c) []) = c >= ' '+ isPrintableEvent _ = False++keymap :: Keymap+keymap =+ selfInsertKeymap <|> makeKeymap keys++keys :: KList+keys =+ [ ( "TAB", write $ autoIndentB)+ , ( "RET", write $ repeatingArg $ insertB '\n')+ , ( "DEL", write $ repeatingArg $ deleteN 1)+ , ( "BACKSP", write $ repeatingArg bdeleteB)+ , ( "C-M-w", write $ appendNextKillE)+ , ( "C-/", write $ repeatingArg undoB)+ , ( "C-_", write $ repeatingArg undoB)+ , ( "C-<left>", write $ repeatingArg prevWordB)+ , ( "C-<right>",write $ repeatingArg nextWordB)+ , ( "C-<home>", write $ repeatingArg topB)+ , ( "C-<end>", write $ repeatingArg botB)+ , ( "C-@", write $ (pointB >>= setSelectionMarkPointB))+ , ( "C-SPC", write $ (pointB >>= setSelectionMarkPointB))+ , ( "C-a", write $ repeatingArg (maybeMoveB Line Backward))+ , ( "C-b", write $ repeatingArg leftB)+ , ( "C-d", write $ repeatingArg $ deleteN 1)+ , ( "C-e", write $ repeatingArg (maybeMoveB Line Forward))+ , ( "C-f", write $ repeatingArg rightB)+ , ( "C-g", write $ unsetMarkB)+ -- , ( "C-g", write $ keyboardQuitE)+ -- C-g should be a more general quit that also unsets the mark.+ , ( "C-i", write $ autoIndentB)+ , ( "C-j", write $ repeatingArg $ insertB '\n')+ , ( "C-k", write $ killLineE)+ , ( "C-m", write $ repeatingArg $ insertB '\n')+ , ( "C-n", write $ repeatingArg $ moveB VLine Forward)+ , ( "C-o", write $ repeatingArg (insertB '\n' >> leftB))+ , ( "C-p", write $ repeatingArg $ moveB VLine Backward)+ , ( "C-q", insertNextC)+ , ( "C-r", isearchKeymap Backward)+ , ( "C-s", isearchKeymap Forward)+ , ( "C-t", write $ repeatingArg $ swapB)+ , ( "C-u", readArgC)+ , ( "C-v", write $ scrollDownE)+ , ( "M-v", write $ scrollUpE)+ , ( "C-w", write $ killRegionE)+ , ( "C-z", write $ suspendEditor)+ , ( "C-x ^", write $ repeatingArg enlargeWinE)+ , ( "C-x 0", write $ closeWindow)+ , ( "C-x 1", write $ closeOtherE)+ , ( "C-x 2", write $ splitE)+ , ( "C-x C-c", write $ quitEditor)+ , ( "C-x C-f", write $ findFile)+ , ( "C-x C-s", write $ fwriteE)+ , ( "C-x C-w", write $ withMinibuffer "Write file: "+ (completeFileName Nothing)+ fwriteToE+ )+ , ( "C-x C-x", write $ exchangePointAndMarkB)+ , ( "C-x b", write $ switchBufferE)+ , ( "C-x d", write $ dired)+ , ( "C-x e e", write $ evalRegionE)+ , ( "C-x o", write $ nextWinE)+ , ( "C-x k", write $ killBufferE)+ -- , ( "C-x r k", write $ killRectE)+ -- , ( "C-x r o", write $ openRectE)+ -- , ( "C-x r t", write $ stringRectE)+ -- , ( "C-x r y", write $ yankRectE)+ , ( "C-x u", write $ repeatingArg undoB)+ , ( "C-x v", write $ repeatingArg shrinkWinE)+ , ( "C-y", write $ yankE)+ , ( "M-!", write $ shellCommandE)+ , ( "M-/", write $ wordCompleteB)+ , ( "M-<", write $ repeatingArg topB)+ , ( "M->", write $ repeatingArg botB)+ , ( "M-%", write $ queryReplaceE)+ , ( "M-BACKSP", write $ repeatingArg bkillWordB)+ -- , ( "M-a", write $ repeatingArg backwardSentenceE)+ , ( "M-b", write $ repeatingArg prevWordB)+ , ( "M-c", write $ repeatingArg capitaliseWordB)+ , ( "M-d", write $ repeatingArg killWordB)+ -- , ( "M-e", write $ repeatingArg forwardSentenceE)+ , ( "M-f", write $ repeatingArg nextWordB)+ , ( "M-g g", write $ gotoLn)+ -- , ( "M-h", write $ repeatingArg markParagraphE)+ -- , ( "M-k", write $ repeatingArg killSentenceE)+ , ( "M-l", write $ repeatingArg lowercaseWordB)+ , ( "M-t", write $ repeatingArg $ transposeB Word Forward)+ , ( "M-u", write $ repeatingArg uppercaseWordB)+ , ( "M-w", write $ killRingSaveE)+ , ( "M-x", write $ executeExtendedCommandE)+ , ( "M-y", write $ yankPopE)+ , ( "<home>", write $ repeatingArg moveToSol)+ , ( "<end>", write $ repeatingArg moveToEol)+ , ( "<left>", write $ repeatingArg leftB)+ , ( "<right>", write $ repeatingArg rightB)+ , ( "<up>", write $ repeatingArg (moveB VLine Backward))+ , ( "<down>", write $ repeatingArg (moveB VLine Forward))+ , ( "C-<up>", write $ repeatingArg $ prevNParagraphs 1)+ , ( "C-<down>", write $ repeatingArg $ nextNParagraphs 1)+ , ( "<next>", write $ repeatingArg downScreenB)+ , ( "<prior>", write $ repeatingArg upScreenB)+ ]+
+ Yi/Keymap/Emacs/Keys.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}++-- Copyright (c) 2005, 2008 Jean-Philippe Bernardy++module Yi.Keymap.Emacs.Keys (readKey, showKey, printableChars, + KList, makeKeymap, rebind) where+ +import Yi.Event+import Yi.Debug+import Data.Char+import Data.List+import Data.Maybe+import qualified Data.Map as M+import Prelude hiding (error)+import Text.ParserCombinators.ReadP+import Yi.Keymap+import qualified Yi.Interact as I++-- * The keymap abstract definition++type KList = [(String, Keymap)]++-- | Create a binding processor from 'kmap'.+makeKeymap :: KList -> KeymapM ()+makeKeymap kmap = I.choice [I.events (readKey k) >> a | (k,a) <- kmap]++rebind :: KList -> KeymapEndo+rebind keys = (makeKeymap keys I.<||)+++printableChars :: [Char]+printableChars = map chr [32..127]+++-- * Key parser++x_ :: [Modifier] -> Event -> Event+x_ mods' (Event k mods) = Event k (nub (mods'++mods))+++parseCtrl :: ReadP Event+parseCtrl = do string "C-"+ k <- parseRegular+ return $ x_ [MCtrl] k++parseMeta :: ReadP Event+parseMeta = do string "M-"+ k <- parseRegular+ return $ x_ [MMeta] k++parseCtrlMeta :: ReadP Event+parseCtrlMeta = do string "C-M-"+ k <- parseRegular+ return $ x_ [MMeta, MCtrl] k+++keyNames :: [(Key, String)]+keyNames = [(KASCII ' ', "SPC"),+ (KASCII '\t', "TAB"),+ (KLeft, "<left>"),+ (KRight, "<right>"),+ (KDown, "<down>"),+ (KUp, "<up>"),+ (KDel, "DEL"),+ (KBS, "BACKSP"),+ (KPageDown, "<next>"),+ (KPageUp, "<prior>"),+ (KHome, "<home>"),+ (KEnd, "<end>"),+ (KEnter, "RET")+ ]++parseRegular :: ReadP Event+parseRegular = choice [string s >> return (Event c []) | (c,s) <- keyNames]+ +++ do c <- satisfy (`elem` printableChars)+ return (Event (KASCII c) [])++parseKey :: ReadP [Event]+parseKey = sepBy1 (choice [parseCtrlMeta, parseCtrl, parseMeta, parseRegular])+ (munch1 isSpace)++readKey :: String -> [Event]+readKey s = case readKey' s of+ [r] -> r+ rs -> error $ "readKey: " ++ s ++ show (map ord s) ++ " -> " ++ show rs++readKey' :: String -> [[Event]]+readKey' s = map fst $ nub $ filter (null . snd) $ readP_to_S parseKey $ s++-- * Key printer+-- FIXME: C- and M- should be swapped when they are both there.+showKey :: [Event] -> String+showKey = concat . intersperse " " . map showEv+ where+ showEv (Event k mods) = concatMap showMod mods ++ showK k+ showMod MCtrl = "C-"+ showMod MShift = "S-"+ showMod MMeta = "M-"++ showK (KASCII x) = [x]+ showK c = fromJust $ M.lookup c $ M.fromList keyNames++
+ Yi/Keymap/Emacs/KillRing.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Copyright (c) 2005,8 Jean-Philippe Bernardy++module Yi.Keymap.Emacs.KillRing where++import Yi.Keymap.Emacs.UnivArgument+import Yi.Buffer.Region+import Yi.Keymap+import Yi.Buffer+import Yi.Buffer.HighLevel+import Yi.Accessor+import Yi.Editor+import Control.Monad ( when, replicateM_ )+import Yi.KillRing+++-- * Killring actions+++--- | C-w+killRegionE :: YiM ()+killRegionE = do r <- withBuffer getSelectRegionB+ text <- withBuffer $ readRegionB r+ killringPut text+ withBuffer unsetMarkB+ withBuffer $ deleteRegionB r++-- | C-k+killLineE :: YiM ()+killLineE = withUnivArg $ \a -> case a of+ Nothing -> killRestOfLineE+ Just n -> replicateM_ (2*n) killRestOfLineE++killringPut :: String -> YiM ()+killringPut s = withEditor $ modifyA killringA $ krPut s++-- | Kill the rest of line+killRestOfLineE :: YiM ()+killRestOfLineE =+ do eol <- withBuffer atEol+ l <- withBuffer readRestOfLnB+ killringPut l+ withBuffer deleteToEol+ when eol $+ do c <- withBuffer readB+ killringPut [c]+ withBuffer (deleteN 1)++-- | C-y+yankE :: EditorM ()+yankE = do (text:_) <- getsA killringA krContents+ withBuffer0 $ do pointB >>= setSelectionMarkPointB+ insertN text+ unsetMarkB++-- | M-w+killRingSaveE :: YiM ()+killRingSaveE = do text <- withBuffer (readRegionB =<< getSelectRegionB)+ killringPut text+ withBuffer unsetMarkB+-- | M-y++-- TODO: Handle argument, verify last command was a yank+yankPopE :: EditorM ()+yankPopE = do withBuffer0 (deleteRegionB =<< getSelectRegionB)+ modifyA killringA $ \kr ->+ let ring = krContents kr+ in kr {krContents = tail ring ++ [head ring]}+ yankE++-- | C-M-w+appendNextKillE :: YiM ()+appendNextKillE = withEditor $ modifyA killringA (\kr -> kr {krKilled=True})
+ Yi/Keymap/Emacs/UnivArgument.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving #-}++-- Copyright (c) 2005, 2008 Jean-Philippe Bernardy++module Yi.Keymap.Emacs.UnivArgument where++import Yi.Core+import Yi.Editor+import Yi.Keymap++import Data.Maybe+import Data.Dynamic++import Control.Monad ( replicateM_ )++newtype UniversalArg = UniversalArg (Maybe Int)+ deriving Typeable++-- doing the argument precisely is kind of tedious.+-- read: http://www.gnu.org/software/emacs/manual/html_node/Arguments.html+-- and: http://www.gnu.org/software/emacs/elisp-manual/html_node/elisp_318.html++instance Initializable UniversalArg where+ initial = UniversalArg Nothing+++withUnivArg :: YiAction (m ()) () => (Maybe Int -> m ()) -> YiM ()+withUnivArg cmd = do UniversalArg a <- withEditor getDynamic+ runAction $ makeAction (cmd a)+ withEditor $ setDynamic $ UniversalArg Nothing++withIntArg :: YiAction (m ()) () => (Int -> m ()) -> YiM ()+withIntArg cmd = withUnivArg $ \arg -> cmd (fromMaybe 1 arg)++repeatingArg :: (Monad m, YiAction (m ()) ()) => m () -> YiM ()+repeatingArg f = withIntArg $ \n -> replicateM_ n f
+ Yi/Keymap/Emacs/Utils.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++-- Copyright (c) 2005,2007,2008 Jean-Philippe Bernardy++{-+ This module is aimed at being a helper for the Emacs keybindings.+ In particular this should be useful for anyone that has a custom+ keymap derived from or based on the Emacs one.+-}++module Yi.Keymap.Emacs.Utils+ ( KList+ , makeKeymap+ , changeBufferNameE+ , rebind+ , withMinibuffer+ , queryReplaceE+ , isearchKeymap+ , shellCommandE+ , executeExtendedCommandE+ , evalRegionE+ , readArgC+ , gotoLineE+ , scrollDownE+ , scrollUpE+ , switchBufferE+ , killBufferE+ , insertSelf+ , insertNextC+ , insertTemplate+ , findFile+ , completeFileName+ , completeBufferName+ )+where++{- Standard Library Module Imports -}+import Control.Monad+ ()+import Control.Monad.Trans+ ( lift+ , liftIO+ )+import Data.Char+ ( ord+ , isDigit+ , isSpace+ )+import Data.List+ ( isPrefixOf+ , (\\)+ )+import Data.Maybe+ ( fromMaybe )+import System.Exit+ ( ExitCode( ExitSuccess,ExitFailure ) )+import System.FilePath+ ( takeDirectory+ , isAbsolute+ , pathSeparator+ , (</>)+ , addTrailingPathSeparator+ , splitDirectories+ , joinPath+ , normalise+ , hasTrailingPathSeparator+ )+import System.Directory+ ( doesDirectoryExist+ , getHomeDirectory+ , getCurrentDirectory+ , getDirectoryContents+ )++{- External Library Module Imports -}+{- Local (yi) module imports -}+import Yi.Yi+import Yi.Keymap.Emacs.UnivArgument+import Yi.Keymap.Emacs.Keys+import Yi.Buffer+import Yi.Process+import Yi.Editor+import Yi.Completion+import Yi.MiniBuffer+import Yi.Templates+ ( addTemplate+ , templateNames+ )++{- End of Module Imports -}+++---------------------------+-- Changing the buffer name quite useful if you have+-- several the same.++changeBufferNameE :: YiM ()+changeBufferNameE =+ withMinibuffer "New buffer name:" return strFun+ where+ strFun :: String -> YiM ()+ strFun = withBuffer . setnameB++----------------------------+-- shell-command+shellCommandE :: YiM ()+shellCommandE = do+ withMinibuffer "Shell command:" return $ \cmd -> do+ (cmdOut,cmdErr,exitCode) <- lift $ runShellCommand cmd+ case exitCode of+ ExitSuccess -> withEditor $ newBufferE "*Shell Command Output*" cmdOut >> return ()+ ExitFailure _ -> msgEditor cmdErr++-----------------------------+-- isearch+selfSearchKeymap :: Keymap+selfSearchKeymap = do+ Event (KASCII c) [] <- satisfy (const True)+ write (isearchAddE [c])++searchKeymap :: Keymap+searchKeymap = selfSearchKeymap <|> makeKeymap+ [--("C-g", isearchDelE), -- Only if string is not empty.+ ("C-r", write isearchPrevE),+ ("C-s", write isearchNextE),+ ("C-w", write isearchWordE),+ ("BACKSP", write $ isearchDelE)]++isearchKeymap :: Direction -> Keymap+isearchKeymap direction = do+ write $ isearchInitE direction+ many searchKeymap+ foldr1 (<||) [events (readKey "C-g") >> write isearchCancelE,+ events (readKey "C-m") >> write isearchFinishE,+ events (readKey "RET") >> write isearchFinishE,+ write isearchFinishE]++----------------------------+-- query-replace+queryReplaceE :: YiM ()+queryReplaceE = do+ withMinibuffer "Replace:" return $ \replaceWhat -> do+ withMinibuffer "With:" return $ \replaceWith -> do+ b <- withEditor $ getBuffer+ let replaceBindings = [("n", write $ qrNext b replaceWhat),+ ("y", write $ qrReplaceOne b replaceWhat replaceWith),+ ("q", write $ closeBufferAndWindowE),+ ("C-g", write $ closeBufferAndWindowE)+ ]+ spawnMinibufferE+ ("Replacing " ++ replaceWhat ++ "with " ++ replaceWith ++ " (y,n,q):")+ (const (makeKeymap replaceBindings))+ (qrNext b replaceWhat)++executeExtendedCommandE :: YiM ()+executeExtendedCommandE = do+ withMinibuffer "M-x" completeFunctionName execEditorAction++evalRegionE :: YiM ()+evalRegionE = do+ withBuffer (getSelectRegionB >>= readRegionB) >>= evalE++-- * Code for various commands+-- This ideally should be put in their own module,+-- without a prefix, so M-x ... would be easily implemented+-- by looking up that module's contents+++insertSelf :: Char -> YiM ()+insertSelf = repeatingArg . insertB++insertNextC :: KeymapM ()+insertNextC = do c <- satisfy (const True)+ write $ repeatingArg $ insertB (eventToChar c)+++-- Inserting a template from the templates defined in Yi.Templates.hs+insertTemplate :: YiM ()+insertTemplate =+ withMinibuffer "template-name:" completeTemplateName $ withEditor . addTemplate+ where+ completeTemplateName :: String -> YiM String+ completeTemplateName s = withEditor $ completeInList s (isPrefixOf s) templateNames++-- | C-u stuff+readArgC :: KeymapM ()+readArgC = do readArg' Nothing+ write $ do UniversalArg u <- withEditor getDynamic+ logPutStrLn (show u)+ msgEditor ""++readArg' :: Maybe Int -> KeymapM ()+readArg' acc = do+ write $ msgEditor $ "Argument: " ++ show acc+ c <- satisfy (const True) -- FIXME: the C-u will read one character that should be part of the next command!+ case c of+ Event (KASCII d) [] | isDigit d -> readArg' $ Just $ 10 * (fromMaybe 0 acc) + (ord d - ord '0')+ _ -> write $ setDynamic $ UniversalArg $ Just $ fromMaybe 4 acc+++findFile :: YiM ()+findFile = do maybePath <- withBuffer getfileB+ startPath <- liftIO $ getFolder maybePath+ withMinibuffer "find file:" (completeFileName (Just startPath)) $ \filename -> do {+ let filename' = fixFilePath startPath filename+ ; msgEditor $ "loading " ++ filename'+ ; fnewE filename'+ }+++-- | Fix entered file path by prepending the start folder if necessary,+-- | removing .. bits, and normalising.+fixFilePath :: String -> String -> String+fixFilePath start path =+ let path' = if isAbsolute path then path else start </> path+ in (normalise . joinPath . dropDotDot . splitDirectories) path'++-- | turn a/b/../c into a/c etc+dropDotDot :: [String] -> [String]+dropDotDot pathElems = case ddd pathElems of+ (False, result) -> result+ (True, result) -> dropDotDot result+ where ddd [] = (False, [])+ ddd ("/":"..":xs) = (True, "/":xs)+ ddd (_:"..":xs) = (True, xs)+ ddd (x:xs) = let (changed, rest) = ddd xs+ in (changed, x:rest)++-- | Given a path, trim the file name bit if it exists. If no path given,+-- | return current directory+getFolder :: Maybe String -> IO String+getFolder Nothing = getCurrentDirectory+getFolder (Just path) = do+ isDir <- doesDirectoryExist path+ let dir = if isDir then path else takeDirectory path+ if null dir then getCurrentDirectory else return dir+++-- | Goto a line specified in the mini buffer.+{-# DEPRECATED gotoLineE "This is not necessary for Emacs keymap; should be moved to contrib" #-}+gotoLineE :: YiM ()+gotoLineE =+ withMinibuffer "Go to line:" return gotoAction+ where+ gotoAction :: String -> YiM ()+ gotoAction s =+ case parseLineAndChar s of+ Nothing -> msgEditor "line and column number parse error"+ -- considering putting "gotoLineAndCol :: Int -> Int -> BufferM ()+ -- into Buffer.hs+ Just (l, c) -> withBuffer $ do gotoLn l+ rightN c++ -- This is actually relatively forgiving, for example "10.23xyh" will still+ -- take you to line number 10 column number 23+ -- in fact you can have any non digit character as the separator eg+ -- "10:24" or "10 23"+ -- In fact it need not be one character that is the separator, for example+ -- you can have: "3 my giddy aunt 43" and this will take you to line 3+ -- column 43.+ parseLineAndChar :: String -> Maybe (Int, Int)+ parseLineAndChar s+ | null lineString = Nothing+ | null colString = Just (read lineString, 0)+ | otherwise = Just (read lineString, read colString)+ where+ (lineString, rest) = break (not . isDigit) $ dropWhile isSpace s+ colString = takeWhile isDigit $ dropWhile (not . isDigit) rest++-- debug :: String -> Keymap+-- debug = write . logPutStrLn++completeBufferName :: String -> YiM String+completeBufferName s = withEditor $ do+ bs <- getBuffers+ completeInList s (isPrefixOf s) (map name bs)++completeFileName :: Maybe String -> String -> YiM String+completeFileName start s0 = do+ curDir <- case start of+ Nothing -> do bufferPath <- withBuffer getfileB+ liftIO $ getFolder bufferPath+ (Just path) -> return path+ homeDir <- lift $ getHomeDirectory+ let s = if (['~',pathSeparator] `isPrefixOf` s0) then addTrailingPathSeparator homeDir ++ drop 2 s0 else s0+ sDir = if hasTrailingPathSeparator s then s else takeDirectory s+ searchDir = if null sDir then curDir+ else if isAbsolute sDir then sDir+ else curDir </> sDir+ fixTrailingPathSeparator f = do+ isDir <- doesDirectoryExist (searchDir </> f)+ return $ if isDir then addTrailingPathSeparator f else f+ files <- lift $ getDirectoryContents searchDir+ let files' = files \\ [".", ".."]+ fs <- lift $ mapM fixTrailingPathSeparator files'+ withEditor $ completeInList s (isPrefixOf s) $ map (sDir </>) fs++completeFunctionName :: String -> YiM String+completeFunctionName s = do+ names <- getAllNamesInScope+ withEditor $ completeInList s (isPrefixOf s) names++scrollDownE :: YiM ()+scrollDownE = withUnivArg $ \a -> withBuffer $+ case a of+ Nothing -> downScreenB+ Just n -> replicateM_ n lineDown++scrollUpE :: YiM ()+scrollUpE = withUnivArg $ \a -> withBuffer $+ case a of+ Nothing -> upScreenB+ Just n -> replicateM_ n lineUp++switchBufferE :: YiM ()+switchBufferE = withMinibuffer "switch to buffer:" completeBufferName $ withEditor . switchToBufferWithNameE++killBufferE :: YiM ()+killBufferE = withMinibuffer "kill buffer:" completeBufferName $ withEditor . closeBufferE
+ Yi/Keymap/JP.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE FlexibleContexts #-}+module Yi.Keymap.Normal where++import Control.Monad.State+import Data.Char+import Yi.Keymap.Emacs.Utils (insertSelf)+import Yi.Yi+import qualified Yi.Interact as I (choice, I())++leftHand, rightHand :: [String]+leftHand = ["qwert", "asdfg", "zxcvb"]+rightHand = ["yuiop", "hjkl;", "nm,./"]++{-++qqq www eee rrr ttt yyy uuu iii ooo ppp+ aaa sss ddd fff ggg hhh jjj kkk lll ;;;+ zzz xxx ccc vvv bbb nnn mmm ,,, ... ///++-}++type Process a = (StateT TextUnit (I.I Event Action)) a+++-- data Mark = Paste | SetMark | Cut | Copy | SwitchMark+-- data Special = Complete | Undo | Indent | Search++{-+data Action = TextA Direction Unit Operation+ | YiA (YiM ())+ | EditorA+-}++selfInsertKeymap :: Process ()+selfInsertKeymap = do+ Event (KASCII c) [] <- satisfy isPrintableEvent+ write (insertSelf c)+ where isPrintableEvent (Event (KASCII c) []) = c >= ' '+ isPrintableEvent _ = False++retKeymap :: Process ()+retKeymap = do+ Event KEnter [] <- anyEvent+ write (insertSelf '\n')++insertKeymap :: StateT TextUnit (I Event Action) ()+insertKeymap = do+ keyEv 'g'+ many (selfInsertKeymap <|> retKeymap <|> quickCmdKeymap)+ Event KEnter [MCtrl] <- anyEvent+ return ()++quickCmdKeymap :: (MonadInteract m Action Event) => m ()+quickCmdKeymap = I.choice $ concat $ zipWith (zipWith mkCmd) commands rightHand+ where mkCmd cmd ch = do+ Event (KASCII c) [MCtrl] <- anyEvent+ when (c /= ch) $ fail $ "expected " ++ [ch]+ write (cmd Character)++quitKeymap :: Process ()+quitKeymap = do+ keyEv 'q'+ write quitEditor++unrecognized :: Process ()+unrecognized = do+ e <- anyEvent+ write (msgEditor $ "unrecognized: " ++ show e)++commandsKeymap :: Process ()+commandsKeymap = quitKeymap <|| (I.choice $ insertKeymap : (concat $ (cmds ++ unts))) <|| unrecognized+ where+ cmds :: [[Process ()]]+ cmds = zipWith (zipWith mkCmd) commands rightHand+ unts = zipWith (zipWith mkUnt) units leftHand+ mkCmd :: (TextUnit -> BufferM ()) -> Char -> Process ()+ mkCmd cmd ch = do+ keyEv ch+ currentUnit <- get+ write (cmd currentUnit)+ mkUnt unt ch = do+ keyEv ch+ put unt++keyEv :: (MonadInteract m w Event) => Char -> m Event+keyEv c = satisfy (== Event (KASCII c) [])++keymap :: Keymap+keymap = runProcess $ (many commandsKeymap >> return ())+++{-+Commands: (right hand)+++ cop cut del del com+ pop pas mov mov sea '''+ mpp mxp xpo xpo und++com: complete+und: undo+sea: start incremental search of the Unit at point+pop: pop-yank+pas: paste+xpo: transpose in given direction+''': search start from empty+mxp: exchange point and mark+mpp: mark pop+cop: copy++-}++commands :: [[TextUnit -> BufferM ()]]+commands = [[copy, cut, del b, del f, complete],+ [pop, paste, move b, move f, search],+ [mpp, mxp, xpo b, xpo f, undo]]+ where copy = todo+ cut = todo+ pop = todo+ mpp = todo+ mxp = todo+ complete = todo+ paste = todo+ search = todo+ undo = const undoB+ move dir u = execB Move u dir+ del dir u = deleteB u dir+ xpo dir u = execB Transpose u dir+ b = Backward+ f = Forward+ todo = \_ -> return ()+++{-+Units: (left hand)+++doc pag col ver ovr+ par lin wor cha ins+ *** *** *** sea buf+-}++document, page, column :: TextUnit+document = Character+page = Character+column = Character++units :: [[TextUnit]]+units = [+ [document, page, column, VLine],+ [Paragraph, Line, Word, Character]+ ]++runProcess :: Process () -> Keymap+runProcess p = fmap fst $ runStateT p Character++{-+ins: go to insert mode+ovr: go to overwrite mode+sea: navigate searched items.+++... free+*** reserved for normal emacs usage.++----------+++C-: briefly switch to character mode+M-: briefly switch to word mode++C-mode: go to that mode++-}++
+ Yi/Keymap/Joe.hs view
@@ -0,0 +1,282 @@+-- Copyright (c) 2004, 2008 Tuomo Valkonen++-- Joe-ish keymap for Yi.++module Yi.Keymap.Joe (+ keymap+) where++import Control.Monad.State+import Yi.Yi+import Yi.Char+import Yi.Keymap.Emacs.KillRing++-- ---------------------------------------------------------------------++type JoeProc a = (Interact Char) a++type JoeMode = JoeProc ()++-- ---------------------------------------------------------------------++-- The Keymap++(++>) :: String -> Action -> JoeMode+s ++> a = s &&> write a++(&&>) :: String -> JoeMode -> JoeMode+s &&> p = mapM_ event s >> p++klist :: JoeMode+klist = choice [+ -- Editing and movement+ "\^K\^U" ++> topB,+ "\^K\^V" ++> botB,+ "\^A" ++> moveToSol,+ "\^E" ++> moveToSol,+ "\^B" ++> leftB,+ "\^F" ++> rightB,+ "\^P" ++> (execB Move VLine Backward),+ "\^N" ++> (execB Move VLine Forward),+ "\^U" ++> upScreenB,+ "\^V" ++> downScreenB,+ "\^D" ++> (deleteN 1),+ "\BS" ++> bdeleteB,+ "\^J" ++> killLineE,+ "\^[J" ++> (moveToSol >> killLineE),+ "\^Y" ++> killLineE,+ "\^_" ++> undoB,+ "\^^" ++> redoB,+ "\^X" ++> nextWordB,+ "\^Z" ++> prevWordB,+ "\^W" ++> killWordB,+ "\^O" ++> bkillWordB,+-- "\^K\^R" &&> queryInsertFileE,+ -- Search+ --"\^K\^F" &&> querySearchRepE,+ --"\^L" &&> nextSearchRepE,+ "\^K\^L" &&> gotoLn,+ -- Buffers+ "\^K\^S" &&> queryBufW,+ "\^C" ++> closeWindow,+ "\^K\^D" &&> querySaveE,+ -- Copy&paste+ --"\^K^B" ++> setMarkE,+ --"\^K^K" ++> copyE,+ --"\"K^Y" ++> cutE,+ --"\"K^C" ++> pasteE,+ --"\"K^W" &&> querySaveSelectionE,+ --"\"K/" &&> queryFilterSelectionE,++ -- Windows+ "\^K\^N" ++> nextBufW,+ "\^K\^P" ++> prevBufW,+ "\^K\^S" ++> splitE,+ "\^K\^O" ++> nextWinE,+ "\^C" ++> closeWindow, -- Wrong, should close buffer++ -- Global+ "\^R" ++> refreshEditor,+ "\^K\^X" ++> quitEditor,+ "\^K\^Z" ++> suspendEditor,+ "\^K\^E" &&> queryNewE+ ]++keymap :: Keymap+keymap = runProc klist++runProc :: JoeMode -> Keymap+runProc = comap eventToChar++-- ---------------------------------------------------------------------++-- Commenting out to avoid compile warnings until fn is needed+-- getFileE :: EditorM FilePath+-- getFileE = do bufInfo <- bufInfoB+-- let fp = bufInfoFileName bufInfo+-- return fp+++-- insertFileE :: String -> Action+-- insertFileE f = lift (readFile f) >>= insertNE+++-- ---------------------------------------------------------------------++-- Helper routines++isCancel :: Char -> Bool+isCancel '\^G' = True+isCancel '\^C' = True+isCancel _ = False++-- Commenting out to avoid compile warnings until fn is needed+-- isect :: Eq a => [a] -> [a] -> Bool+-- [] `isect` _ = False+-- (e:ee) `isect` l = e `elem` l || ee `isect` l++-- Commenting out to avoid compile warnings until fn is needed+-- escape2rx :: String -> String+-- escape2rx [] = []+-- escape2rx ('^':cs) = '\\':'^':escape2rx cs+-- escape2rx (c:cs) = '[':c:']':escape2rx cs+++-- ---------------------------------------------------------------------++-- Query support+++simpleq :: String -> String -> (String -> Action) -> JoeMode+simpleq prompt initialValue act = do+ s <- echoMode prompt initialValue+ maybe (return ()) (write . act) s++-- | A simple line editor.+-- @echoMode prompt exitProcess@ runs the line editor; @prompt@ will+-- be displayed as prompt, @exitProcess@ is a process that will be+-- used to exit the line-editor sub-process if it succeeds on input+-- typed during edition.++echoMode :: String -> String -> JoeProc (Maybe String)+echoMode prompt initialValue = do+ write (logPutStrLn "echoMode")+ result <- lineEdit initialValue+ return result+ where lineEdit s =+ do write $ msgEditor (prompt ++ s)+ choice [satisfy isEnter >> return (Just s),+ satisfy isCancel >> return Nothing,+ satisfy isDel >> lineEdit (take (length s - 1) s),+ do c <- satisfy validChar; lineEdit (s++[c])]++-- Commenting out to avoid compile warnings until fn is needed+-- query :: String -> [(String, JoeMode)] -> JoeMode+-- query prompt ks = write (msgEditor prompt) >> loop+-- where loop = choice $ (satisfy (isEnter ||| isCancel) >> return ()) :+-- [oneOf cs >> a | (cs,a) <- ks]+-- ++ [(anyEvent >> loop)]+-- (|||) = liftM2 (||)++-- Commenting out to avoid compile warnings until fn is needed+-- queryKeys :: String -> [(String, Action)] -> JoeMode+-- queryKeys prompt ks = query prompt [(cs,write a) | (cs,a) <- ks]+++-- ---------------------------------------------------------------------++-- Some queries++queryNewE, querySaveE, queryGotoLineE, queryBufW :: JoeMode++-- querySearchRepE, nextSearchRepE :: JoeMode+++queryNewE = simpleq "File name: " [] fnewE+queryGotoLineE = simpleq "Line number: " [] (gotoLn . read)+-- queryInsertFileE :: JoeMode+-- queryInsertFileE = simpleq "File name: " [] insertFileE+queryBufW = simpleq "Buffer: " [] unimplementedQ+++-- TODO: this could either use the method in the Nano keymap or the Emacs keymap.+-- (metaM used change the current keymap)+querySaveE = return ()+--querySaveE = write $+-- getFileE >>= \f -> metaM $ runProc $ (simpleq "File name: " f fwriteToE >> klist)++++-- ---------------------------------------------------------------------++-- Search queries+-- TODO: search is currently broken in Core anyway; to re-implement when it gets fixed.+{-++queryReplace :: SearchMatch+ -> String+ -> IO (Maybe SearchMatch)+ -> JoeMode+queryReplace m s sfn =+ queryKeys "Replace? (Y)es (N)o (R)est? " [("yY", repl m False), ("rR", repl m True), ("nN", skip m)]+ where+ skip (_, j) st _ = return $ do+ res <- do_next j+ case res of+ Nothing -> metaM keymap+ Just p -> metaM $ runProc $ queryReplace p s sfn++ repl mm_ rest_ st_ cs_ = return $ repl_ mm_ rest_ st_ cs_+ where+ repl_ mm@(i, _) rest st cs = do+ do_replace mm s+ res <- do_next (i+length s)+ case (res, rest) of+ (Nothing, _) -> metaM keymap+ (Just p, True) -> repl_ p rest st cs+ (Just p, False) -> metaM $ runProc $ queryReplace p s sfn++ do_replace (i, j) ss = withWindow_ $ \w b -> do+ moveTo b i+ deleteN b (j-i)+ insertN b ss+ return w++ do_next j = do+ op <- getSelectionMarkPointB+ gotoPointE (j-1) -- Don't replace within replacement+ -- TODO: backwards search+ res <- sfn+ when (isNothing res) (gotoPointE op)+ return res++joeDoSearch :: SearchExp -> Action+joeDoSearch srchexp = do+ res <- sfn+ case res of+ Nothing -> errorEditor "Not found." >> metaM keymap+ Just p -> case js_search_replace st of+ Just rep -> metaM $ runProc $ queryReplace p rep (sfn)+ Nothing -> metaM $ keymap+ where+ sfn = do+ op <- getSelectionMarkPointB+ res <- continueSearch srchexp (js_search_dir st)+ case res of+ Just (Left _) -> gotoPointE op >> return Nothing+ Just (Right p) -> return (Just p)+ Nothing -> return Nothing+++mksearch :: String -> String -> Maybe String -> JoeMode+mksearch s flags repl st _ = return $ do+ srchexp <- searchInit searchrx (js_search_flags newst)+ joeDoSearch srchexp newst+ where+ ignore = if isect "iI" flags then [IgnoreCase] else []+ dir = if isect "bB" flags then GoLeft else GoRight+ searchrx = if isect "xX" flags then s else escape2rx s+ newst = st{+ js_search_dir = dir,+ js_search_flags = ignore,+ js_search_replace = repl+ }++querySearchRepE =+ query "Search term: " [] qflags+ where+ flagprompt = "(I)gnore, (R)eplace, (B)ackward Reg.E(x)p? "+ qflags s = query flagprompt [] (qreplace s)+ qreplace s flags | isect "rR" flags =+ query "Replace with: " [] (mksearch s flags . Just)+ qreplace s flags =+ mksearch s flags Nothing++nextSearchRepE =+ getRegexE >>= \e -> case e of+ Nothing -> metaM $ runProc $ querySearchRepE+ Just se -> joeDoSearch se+-}++unimplementedQ :: String -> Action+unimplementedQ a = errorEditor (a ++ " not implemented.")
+ Yi/Keymap/Mg.hs view
@@ -0,0 +1,618 @@+-- Copyright (c) 2005, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | An keymap that emulates @mg@, an emacs-like text editor. For more+-- information see <http://www.openbsd.org/cgi-bin/man.cgi?query=mg>+--+-- A quick summary:+--+-- > ^F Forward character+-- > ^B Backwards character+-- > ^N Next line+-- > ^P Previous line+-- > ^A Start of line+-- > ^E End of line+-- > ^D delete current character+-- > ^S interactive search forward+-- > ^R interactive search backwards+-- > ^O Open a new line at cursor position+-- > ^T transpose characters+-- > ^U Repeat next command 4 times (can be cascaded i.e. ^u^u^f will move+-- > 16 characters forward)+-- >+-- > ^K kill to end of line (placing into kill buffer)+-- > ^Y yank kill buffer into current location+-- > ^@ set mark+-- > ^W kill region (cuts from previously set mark to current location,+-- > into kill buffer)+-- > M-W copy region (into kill buffer)+-- >+-- > ^V Next page+-- > M-V Previous page+-- > M-< start of buffer+-- > M-> end of buffer+--+-- > ^X^C Quit (you will be asked if you want to save files)+-- > ^X-O Next window.+-- > ^X-N Next window.+-- > ^X-P Previous window.+-- > ^X-U Undo.+--+-- For more key bindings, type ``M-x describe-bindings''.++module Yi.Keymap.Mg (keymap) where++import Yi.Yi+import Yi.Char++import Numeric ( showOct )+import Data.Char ( ord, chr )+import Data.List ((\\), isPrefixOf)+import qualified Data.Map as M+import Control.Arrow+import Control.Exception ( try, evaluate )+import Control.Monad+import Control.Monad.Trans+import Yi.Debug+import Yi.Keymap.Emacs.Utils (findFile, isearchProcess, withMinibuffer, completeFileName)+import Yi.Keymap.Emacs.KillRing+import Yi.String (dropSpace)++------------------------------------------------------------------------++c_ :: Char -> Char+c_ = ctrlLowcase++m_ :: Char -> Char+m_ = setMeta++-- ---------------------------------------------------------------------+-- map extended names to corresponding actions+--+extended2action :: M.Map String MgMode+extended2action = M.fromList [ (ex,a) | (ex,_,a) <- globalTable ]++--+-- map keystrokes to extended names+--+keys2extended :: M.Map [Char] String+keys2extended = M.fromList [ (k,ex) | (ex,ks,_) <- globalTable, k <- ks ]++--+-- map chars to actions+--+keys2action :: [Char] -> MgMode+keys2action ks | Just ex <- M.lookup ks keys2extended+ , Just a <- M.lookup ex extended2action = a+ | otherwise = write $ errorEditor $ "No binding for "++ show ks++--+-- keystrokes only 1 character long+--+unitKeysList :: [Char]+unitKeysList = [ k | (_,ks,_) <- globalTable, [k] <- ks ]++--+-- C-x mappings+--+ctrlxKeysList :: [Char]+ctrlxKeysList = [ k | (_,ks,_) <- globalTable, ['\^X',k] <- ks ]++--+-- M-O mappings+--+metaoKeysList :: [Char]+metaoKeysList = [ k | (_,ks,_) <- globalTable, [m,k] <- ks, m == m_ 'O' ]++------------------------------------------------------------------------+--+-- global key/action/name map+--+globalTable :: [(String,[String],MgMode)]+globalTable = [+ ("apropos",+ [[c_ 'h', 'a']],+ write $ errorEditor "apropos unimplemented"),+ ("backward-char",+ [[c_ 'b'], [m_ 'O', 'D'], [keyLeft]],+ write $ leftB),+ ("backward-kill-word",+ [[m_ '\127']],+ write $ bkillWordB),+ ("backward-word",+ [[m_ 'b']],+ write $ prevWordB),+ ("beginning-of-buffer",+ [[m_ '<']],+ write $ topB),+ ("beginning-of-line",+ [[c_ 'a'], [m_ 'O', 'H']],+ write $ moveToSol),+ ("call-last-kbd-macro",+ [[c_ 'x', 'e']],+ write $ errorEditor "call-last-kbd-macro unimplemented"),+ ("capitalize-word",+ [[m_ 'c']],+ write $ capitaliseWordB),+ ("copy-region-as-kill",+ [[m_ 'w']],+ write $ errorEditor "copy-region-as-kill unimplemented"),+ ("delete-backward-char",+ [['\127'], ['\BS'], [keyBackspace]],+ write $ bdeleteB),+ ("delete-blank-lines",+ [[c_ 'x', c_ 'o']],+ write $ mgDeleteBlanks),+ ("delete-char",+ [[c_ 'd']],+ write $ deleteN 1),+ ("delete-horizontal-space",+ [[m_ '\\']],+ write $ mgDeleteHorizBlanks),+ ("delete-other-windows",+ [[c_ 'x', '1']],+ write $ closeOtherE),+ ("delete-window",+ [[c_ 'x', '0']],+ write $ closeWindow),+ ("describe-bindings",+ [[c_ 'h', 'b']],+ write $ describeBindings),+ ("describe-key-briefly",+ [[c_ 'h', 'c']],+ describeKeyMode),+ ("digit-argument",+ [ [m_ d] | d <- ['0' .. '9'] ],+ write $ errorEditor "digit-argument unimplemented"),+ ("dired",+ [[c_ 'x', 'd']],+ write $ errorEditor "dired unimplemented"),+ ("downcase-region",+ [[c_ 'x', c_ 'l']],+ write $ errorEditor "downcase-region unimplemented"),+ ("downcase-word",+ [[m_ 'l']],+ write $ lowercaseWordB),+ ("end-kbd-macro",+ [[c_ 'x', ')']],+ write $ errorEditor "end-kbd-macro unimplemented"),+ ("end-of-buffer",+ [[m_ '>']],+ write $ botB),+ ("end-of-line",+ [[c_ 'e'], [m_ 'O', 'F']],+ write $ moveToEol),+ ("enlarge-window",+ [[c_ 'x', '^']],+ write $ enlargeWinE),+ ("shrink-window", -- not in mg+ [[c_ 'x', 'v']],+ write $ shrinkWinE),+ ("exchange-point-and-mark",+ [[c_ 'x', c_ 'x']],+ write $ errorEditor "exchange-point-and-mark unimplemented"),+ ("execute-extended-command",+ [[m_ 'x']],+ metaXSwitch),+ ("fill-paragraph",+ [[m_ 'q']],+ write $ errorEditor "fill-paragraph unimplemented"),+ ("find-alternate-file",+ [[c_ 'c', c_ 'v']],+ write $ errorEditor "find-alternate-file unimplemented"),+ ("find-file",+ [[c_ 'x', c_ 'f']],+ findFile),+ ("find-file-other-window",+ [[c_ 'x', '4', c_ 'f']],+ write $ errorEditor "find-file-other-window unimplemented"),+ ("forward-char",+ [[c_ 'f'], [m_ 'O', 'C'], [keyRight]],+ write $ rightB),+ ("forward-paragraph",+ [[m_ ']']],+ write $ nextNParagraphs 1),+ ("forward-word",+ [[m_ 'f']],+ write $ nextWordB),+ ("goto-line",+ [[c_ 'x', 'g']],+ gotoMode),+ ("help-help",+ [[c_ 'h', c_ 'h']],+ write $ errorEditor "help-help unimplemented"),+ ("insert-file",+ [[c_ 'x', 'i']],+ write $ errorEditor "insert-file unimplemented"),+ ("isearch-backward",+ [[c_ 'r']],+ isearchProcess),+ ("isearch-forward",+ [[c_ 's']],+ isearchProcess),+ ("just-one-space",+ [[m_ ' ']],+ write $ insertN ' '),+ ("keyboard-quit",+ [[c_ 'g'],+ [c_ 'h', c_ 'g'],+ [c_ 'x', c_ 'g'],+ [c_ 'x', '4', c_ 'g'],+ [m_ (c_ 'g')]+ ],+ write $ msgEditor "Quit"),+ ("kill-buffer",+ [[c_ 'x', 'k']],+ killBufferMode),+ ("kill-line",+ [[c_ 'k']],+ write $ killLineE),+ ("kill-region",+ [[c_ 'w']],+ write $ errorEditor "kill-region unimplemented"),+ ("kill-word",+ [[m_ 'd']],+ write $ killWordB),+ ("list-buffers",+ [[c_ 'x', c_ 'b']],+ write $ mgListBuffers),+ ("negative-argument",+ [[m_ '-']],+ write $ errorEditor "negative-argument unimplemented"),+ ("newline",+ [[c_ 'm']],+ write $ insertN '\n'),+ ("newline-and-indent",+ [],+ write $ errorEditor "newline-and-indent unimplemented"),+ ("next-line",+ [[c_ 'n'], [m_ 'O', 'B'], [keyDown]], -- doesn't remember goal column+ write $ (execB Move VLine Forward)),+ ("not-modified",+ [[m_ '~']],+ write $ errorEditor "not-modified unimplemented"),+ ("open-line",+ [[c_ 'o']],+ write $ insertB '\n'),+ ("other-window",+ [[c_ 'x', 'n'], [c_ 'x', 'o']],+ write $ nextWinE),+ ("previous-line",+ [[c_ 'p'], [m_ 'O', 'A'], [keyUp]],+ write $ (execB Move VLine Backward)),+ ("previous-window",+ [[c_ 'x', 'p']],+ write $ prevWinE),+ ("query-replace",+ [[m_ '%']],+ write $ errorEditor "query-replace unimplemented"),+ ("quoted-insert",+ [[c_ 'q']],+ insertAnyMode),+ ("recenter",+ [[c_ 'l']],+ write $ errorEditor "recenter unimplemented"),+ ("save-buffer",+ [[c_ 'x', c_ 's']],+ write $ writeFileMode),+ ("save-buffers-kill-emacs",+ [[c_ 'x', c_ 'c']],+ write $ quitEditor), -- should ask to save buffers+ ("save-some-buffers",+ [[c_ 'x', 's']],+ write $ errorEditor "save-some-buffers unimplemented"),+ ("scroll-down",+ [[m_ '[', '5', '~'], [m_ 'v'], [keyPPage]],+ write $ upScreenB),+ ("scroll-other-window",+ [[m_ (c_ 'v')]],+ write $ errorEditor "scroll-other-window unimplemented"),+ ("scroll-up",+ [[c_ 'v'], [m_ '[', '6', '~'], [keyNPage]],+ write $ downScreenB),+ ("search-backward",+ [[m_ 'r']],+ write $ errorEditor "search-backward unimplemented"),+ ("search-forward",+ [[m_ 's']],+ write $ errorEditor "search-forward unimplemented"),+ ("set-fill-column",+ [[c_ 'x', 'f']],+ write $ errorEditor "set-fill-column unimplemented"),+ ("set-mark-command",+ [['\NUL']],+ write $ errorEditor "set-mark-command unimplemented"),+ ("split-window-vertically",+ [[c_ 'x', '2']],+ write $ splitE),+ ("start-kbd-macro",+ [[c_ 'x', '(']],+ write $ errorEditor "start-kbd-macro unimplemented"),+ ("suspend-emacs",+ [[c_ 'z']],+ write $ suspendEditor),+ ("switch-to-buffer",+ [[c_ 'x', 'b']],+ write $ errorEditor "switch-to-buffer unimplemented"),+ ("switch-to-buffer-other-window",+ [[c_ 'x', '4', 'b']],+ write $ errorEditor "switch-to-buffer-other-window unimplemented"),+ ("transpose-chars",+ [[c_ 't']],+ write $ swapB),+ ("undo",+ [[c_ 'x', 'u'], ['\^_']],+ write $ undoB),+ ("universal-argument",+ [[c_ 'u']],+ write $ errorEditor "universal-argument unimplemented"),+ ("upcase-region",+ [[c_ 'x', c_ 'u']],+ write $ errorEditor "upcase-region unimplemented"),+ ("upcase-word",+ [[m_ 'u']],+ write $ uppercaseWordB),+ ("what-cursor-position",+ [[c_ 'x', '=']],+ write $ whatCursorPos),+ ("write-file",+ [[c_ 'x', c_ 'w']],+ writeFileMode),+ ("yank",+ [[c_ 'y']],+ write $ getRegE >>= mapM_ insertN) ]++------------------------------------------------------------------------++type MgMode = Interact Char ()++keymap :: Keymap+keymap = comap eventToChar mode++------------------------------------------------------------------------++-- default bindings+mode :: MgMode+mode = command ++++ ctrlxSwitch ++++ metaSwitch ++++ metaOSwitch ++++ metaXSwitch +++ insert++------------------------------------------------------------------------++-- self insertion+insert :: MgMode+insert = do c <- satisfy (const True); write $ insertN c++-- C- commands+command :: MgMode+command = do c <- oneOf unitKeysList; keys2action [c]++------------------------------------------------------------------------++-- switch to ctrl-X submap+ctrlxSwitch :: MgMode+ctrlxSwitch = do event '\^X' ; write (msgEditor "C-x-"); ctrlxMode+++-- ctrl x submap+ctrlxMode :: MgMode+ctrlxMode = do c <- oneOf ctrlxKeysList; keys2action ['\^X',c]; write msgClr++------------------------------------------------------------------------+--+-- on escape, we'd also like to switch to M- mode+--++-- switch to meta mode+metaSwitch :: MgMode+metaSwitch = do event '\ESC' ; write (msgEditor "ESC-"); metaMode -- hitting ESC also triggers a meta char++--+-- a fake mode. really just looking up the binding for: m_ c+--+metaMode :: MgMode+metaMode = do c <- oneOf ['\0' .. '\255'] -- not quite right+ when ((m_ c) `elem` unitKeysList) $ keys2action [m_ c]+ write msgClr++------------------------------------------------------------------------++-- switch to meta O mode+metaOSwitch :: MgMode+metaOSwitch = event (m_ 'O') >> write (msgEditor "ESC-O-") >> metaOMode++metaOMode :: MgMode+metaOMode = do c <- oneOf metaoKeysList; keys2action [m_ 'O',c]; write msgClr++-- ---------------------------------------------------------------------+-- build a generic line buffer editor, given a mode to transition to+--++echoMode :: String -> Interact Char (Maybe String)+echoMode prompt = do+ write (logPutStrLn "echoMode")+ result <- lineEdit []+ write msgClr+ return result+ where lineEdit s =+ do write $ msgEditor (prompt ++ s)+ (do delete; lineEdit (take (length s - 1) s)+ +++ do c <- anyButDelNlArrow; lineEdit (s++[c])+ +++ do event '\^G'; return Nothing+ +++ do enter; return (Just s))+ anyButDelNlArrow = oneOf $ any' \\ (enter' ++ delete' ++ ['\ESC',keyUp,keyDown])+++withLineEditor :: String -> (String -> MgMode) -> MgMode+withLineEditor prompt cont = do+ s <- echoMode prompt+ case s of+ Nothing -> return ()+ Just x -> cont x+++------------------------------------------------------------------------++-- | execute an extended command+-- we ultimately map the command back to a+-- keystroke, and execute that.++metaXSwitch :: MgMode+metaXSwitch = do (event (m_ 'x') +++ event (m_ 'X')); withLineEditor "M-x " metaXEval++-- | M-x mode, evaluate a string entered after M-x+metaXEval :: String -> MgMode+metaXEval cmd = case M.lookup cmd extended2action of+ Nothing -> write $ msgEditor "[No match]"+ Just a -> a++-- metaXTab :: MgMode++------------------------------------------------------------------------++describeKeyMode :: MgMode+describeKeyMode = describeChar "Describe key briefly: " []++describeChar :: String -> String -> MgMode+describeChar prompt acc = do+ c <- anything+ let keys = acc ++ [c]+ case M.lookup keys keys2extended of+ Just ex -> write $ msgEditor $ (printable keys) ++ " runs the command " ++ ex+ Nothing ->+ -- only continue if this is the prefix of something in the table+ if any (isPrefixOf keys) (M.keys keys2extended)+ then do write $ msgEditor (prompt ++ keys)+ describeChar prompt keys+ else write $ msgEditor $ printable keys ++ " is not bound to any function"++-- ---------------------------------------------------------------------+-- | Writing a file+--++writeFileMode :: MgMode+writeFileMode = withMinibuffer "Write file: "+ (completeFileName Nothing)+ fwriteToE++-- ---------------------------------------------------------------------+-- | Killing a buffer by name++killBufferMode :: MgMode+killBufferMode = withLineEditor "Kill buffer: " $ \buf -> write $ do+ closeBufferE buf++-- ---------------------------------------------------------------------+-- | Goto a line+--++gotoMode :: MgMode+gotoMode = withLineEditor "goto line: " $ \l -> write $ do+ i <- lift $ try . evaluate . read $ l+ case i of Left _ -> errorEditor "Invalid number"+ Right i' -> gotoLn i'+++-- | insert the first character, then switch back to normal mode+insertAnyMode :: MgMode+insertAnyMode = do c <- oneOf ['\0' .. '\255']; write (insertN c)++-- | translate a string into the Emacs encoding of that string+printable :: String -> String+printable = dropSpace . printable'+ where+ printable' ('\ESC':a:ta) = "M-" ++ [a] ++ printable' ta+ printable' ('\ESC':ta) = "ESC " ++ printable' ta+ printable' (a:ta)+ | ord a < 32+ = "C-" ++ [chr (ord a + 96)] ++ " " ++ printable' ta+ | isMeta a+ = "M-" ++ printable' (clrMeta a:ta)+ | ord a >= 127+ = bigChar a ++ " " ++ printable' ta+ | otherwise = [a, ' '] ++ printable' ta++ printable' [] = []++ bigChar c+ | c == keyDown = "<down"+ | c == keyUp = "<up>"+ | c == keyLeft = "<left>"+ | c == keyRight = "<right>"+ | c == keyNPage = "<pagedown>"+ | c == keyPPage = "<pageup>"+ | c == '\127' = "<delete>"+ | otherwise = show c++------------------------------------------------------------------------+-- Mg-specific actions++whatCursorPos :: Action+whatCursorPos = do+ bufInfo <- bufInfoB+ let ln = bufInfoLineNo bufInfo+ col = bufInfoColNo bufInfo+ pt = bufInfoCharNo bufInfo+ pct = bufInfoPercent bufInfo+ c <- readB+ msgEditor $ "Char: "++[c]++" (0"++showOct (ord c) ""+++ ") point="++show pt+++ "("++pct+++ ") line="++show ln+++ " row=? col="++ show col++describeBindings :: Action+describeBindings = newBufferE "*help*" s >> return ()+ where+ s = unlines [ let p = printable k+ in p ++ replicate (17 - length p) ' ' ++ ex+ | (ex,ks,_) <- globalTable+ , k <- ks ]++-- bit of a hack, unfortunately+mgListBuffers :: Action+mgListBuffers = do+ closeBufferE name -- close any previous buffer list buffer+ newBufferE name [] -- new empty one+ bs <- listBuffersE -- get current list+ closeBufferE name -- close temporary one+ newBufferE name (f bs) -- and finally display current one+ return ()+ where+ name = "*Buffer List*"+ f bs = unlines [ " "++(show i)++"\t"++(show n) | (n,i) <- bs ]++--+-- delete all blank lines from this point+mgDeleteBlanks :: Action+mgDeleteBlanks = do+ p <- getSelectionMarkPointB+ moveWhileE (== '\n') GoRight+ q <- getSelectionMarkPointB+ gotoPointE p+ deleteNE (q - p)++-- not quite right, as it will delete, even if no blanks+mgDeleteHorizBlanks :: Action+mgDeleteHorizBlanks = do+ p <- getSelectionMarkPointB+ moveWhileE (\c -> c == ' ' || c == '\t') GoRight+ q <- getSelectionMarkPointB+ gotoPointE p+ deleteNE (q - p)++------------------------------------------------------------------------+--+-- some regular expressions++any', enter', delete' :: [Char]+enter' = ['\n', '\r']+delete' = ['\BS', '\127', keyBackspace ]+any' = ['\0' .. '\255']++delete, enter, anything :: Interact Char Char+delete = oneOf delete'+enter = oneOf enter'+anything = oneOf any'+
+ Yi/Keymap/Nano.hs view
@@ -0,0 +1,235 @@+-- Copyright (c) 2004, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | An emulation of the Nano editor++module Yi.Keymap.Nano ( keymap ) where++import Yi.Yi+import Yi.Keymap.Emacs.KillRing++import Data.Char ( chr, isAlphaNum, toLower )+import Control.Arrow++import Control.Exception ( ioErrors, try, evaluate )+import Control.Monad ( when )+import Control.Monad.Trans ( lift )++-- | Top level function. A function of this type is used by the editor+-- main loop to interpret actions. The second argument to @execLexer@ is+-- our default state.++keymap :: Keymap+keymap = comap eventToChar nano_km++-- | @NanoMode@ is the type of our interactive process.+type NanoMode = Interact Char ()++-- | Helper function: match any char in the input string.+anyChar :: String -> Interact Char Char+anyChar cs = satisfy (`elem` cs)++-- | The default mode is /cmd/ mode. Our other mode is the echo buffer+-- mode. In cmd mode you can insert chars, run commands and switch to+-- the echo buffer mode.+--+nano_km :: NanoMode+nano_km = choice [cmdChar, cmdSwitch, searchChar, insChar]++--+-- Here's where we write a bunch of lexer fragments, corresponding to+-- the different behaviours of the editor: char insertion, cmd actions,+-- cmd line buffer editing, etc.+--++--+-- | Normal chars just insert themselves+--+insChar :: NanoMode+insChar = do c <- anyChar ('\n' : map chr [32 .. 126])+ write $ insertN c++--+-- | Command chars run actions.+--+cmdChar :: NanoMode+cmdChar = choice [event c >> act | (c,act) <- cmdCharFM]++--+-- A key\/action table. This is where we actually map command (^) chars+-- to actions.+--+cmdCharFM :: [(Char, NanoMode)]+cmdCharFM =+ [+ -- ('\127', write $ bdeleteB1), -- ?+ ('\188', write prevBufW) -- 'M-<' ?+ ,('\190', write nextBufW) -- 'M->' ?+ ,('\^A', write moveToSol)+ ,('\^B', write leftB)+ ,('\^D', write deleteN 1)+ ,('\^E', write moveToEol)+ ,('\^F', write rightB)+ ,('\^H', write $ leftB >> deleteN 1)+ ,('\^K', write $ killLineE)+ ,('\^L', write refreshEditor)+ ,('\^M', write $ insertN '\n')+ ,('\^N', write (execB Move VLine Forward))+ ,('\^P', write (execB Move VLine Backward))+ ,('\^U', write undoB)+ ,('\^V', write downScreenB)+ ,('\^X', do write $ do b <- isUnchangedB ; if b then quitEditor else return ()+ switch2WriteMode) -- TODO: separate this+ ,('\^Y', write upScreenB)+ ,('\^Z', write suspendEditor)+ ,('\0', write $ do moveWhileE (isAlphaNum) GoRight+ moveWhileE (not . isAlphaNum) GoRight )+ ,(keyBackspace, write $ leftB >> deleteN 1)+ ,(keyDown, write (execB Move VLine Backward))+ ,(keyLeft, write leftB)+ ,(keyRight, write rightB)+ ,(keyUp, write (execB Move VLine Backward))+ ,('\^G', write $ msgEditor "nano-yi : yi emulating nano")+ ,('\^I', write (do bufInfo <- bufInfoB+ let s = bufInfoFileName bufInfo+ ln = bufInfoLineNo bufInfo+ col = bufInfoColNo bufInfo+ pt = bufInfoCharNo bufInfo+ pct = bufInfoPercent bufInfo+ msgEditor $ "[ line "++show ln++", col "++show col+++ ", char "++show pt++"/"++show s++" ("++pct++") ]"))+ ]++ where+ --+ -- | print a message and switch to sub-mode lexer for Y\/N questions+ --+ switch2WriteMode = do+ write $ msgEditor "Save modified buffer (ANSWERING \"No\" WILL DESTROY CHANGES) ? "+ c <- anyChar "ynYN"+ when (toLower c == 'y') $ write fwriteE+ write quitEditor++--+-- | Switching to the command buffer+--+-- help-mode in nano to be a separate mode too. There are probably+-- others.+--+-- We see a \^R, we need to print a prompt, and switch to+-- the new mode, which will accumulate filename characters until nl.+-- Once the user presses Enter, in the @echo_km@ mode, we are+-- able to evaluate the action char represents (e.g. writing a file).+--+-- Since we're going to edit the command buffer, which is still a+-- slighly buffer magic (unfortunately) we need to explicitly switch+-- focus.+--+cmdSwitch :: NanoMode+cmdSwitch = choice [event c >> echoMode prompt (\s -> anyChar "\n\r" >> write (act s))+ | (c,act,prompt) <- echoCharFM]++--+-- | Nano search behaviour.+--++searchChar :: NanoMode+searchChar = do+ event '\^W'+ write $ do mre <- getRegexE+ let prompt = case mre of -- create a prompt+ Nothing -> "Search: "+ Just (pat,_) -> "Search ["++pat++"]: "+ msgEditor prompt+ -- FIXME: the prompt currently cannot be passed to the echoMode, this prompt will get overwritten.+ -- The fix is NOT to use MetaM!!!+ -- The fix is to stop using getRegexE to remember the last thing searched.+ echoMode "Search: " search_km+ return ()++--+-- When searching, a few extra key bindings become available, which+-- immediately interrupt the echo mode, perform an action, and then drop+-- back to normal mode.+--+-- ^G Get Help ^Y First Line ^R Replace M-C Case Sens M-R Regexp+-- ^C Cancel ^V Last Line ^T Go To Line M-B Direction Up History+--+-- We augment the echo keymap with the following bindings, by passing+-- them in the @OnlyMode@ field of the lexer state. The echo keymap the+-- knows how to add in these extra bindings.+--+search_km :: String -> NanoMode+search_km p = choice [srch_g, srch_y, srch_v, srch_t, srch_c, srch_r, performSearch]+ where -- TODO: use the same style as other modes (list of Char, String -> Action)+ srch_g = event '\^G' >> write (msgEditor "nano-yi : yi emulating nano")++ srch_y = event '\^Y' >> write (gotoLn 0 >> moveToSol)+ srch_v = event '\^V' >> write (do bufInfo <- bufInfoB+ let x = bufInfoLineNo bufInfo+ gotoLn x >> moveToSol)++ srch_t = event '\^T' >> write (msgEditor "unimplemented") -- goto line++ srch_c = event '\^C' >> write (msgEditor "[ Search Cancelled ]")+ srch_r = event '\^R' >> write (msgEditor "unimplemented")++ performSearch = event '\n' >> write (case p of+ [] -> doSearch Nothing [] GoRight+ _ -> doSearch (Just p) [] GoRight)++ -- M-C+ -- M-R+ -- M-B+ -- Up++------------------------------------------------------------------------+--+-- echo buffer mode+--++-- | A simple line editor.+-- @echoMode prompt exitProcess@ runs the line editor; @prompt@ will+-- be displayed as prompt, @exitProcess@ is a process that will be+-- used to exit the line-editor sub-process if it succeeds on input+-- typed during edition.++echoMode :: String -> (String -> Interact Char a) -> Interact Char a+echoMode prompt exitProcess = do+ write (logPutStrLn "echoMode")+ result <- lineEdit []+ return result+ where lineEdit s =+ do write $ msgEditor (prompt ++ s)+ (exitProcess s ++++ (anyChar deleteChars >> lineEdit (take (length s - 1) s)) ++++ (do c <- anyChar ('\n' : map chr [32 .. 126]); lineEdit (s++[c])))++-- | Actions that mess with the echo (or command) buffer. Notice how+-- these actions take a @String@ as an argument, and the second+-- component of the elem of the fm is a string that is used as a+-- prompt.+echoCharFM :: [(Char, String -> Action, String)]+echoCharFM =+ [('\^O',+ \f -> if f == []+ then return ()+ else catchJustE ioErrors (do fwriteToE f ; msgEditor "Wrote current file.")+ (msgEditor . show)+ ,"File Name to Write: ")++ ,('\^_',+ \s -> do e <- lift $ try $ evaluate $ read s+ case e of Left _ -> errorEditor "[ Come on, be reasonable ]"+ Right ln -> gotoLn ln >> moveToSol >> msgClr+ ,"Enter line number: ")+ ]++-- ---------------------------------------------------------------------+-- utilities++-- undef :: Char -> Action+-- undef c = errorEditor $ "Not implemented: " ++ show c++deleteChars :: [Char]+deleteChars = ['\BS', '\127', keyBackspace]+
+ Yi/Keymap/Vi.hs view
@@ -0,0 +1,544 @@+-- Copyright (c) 2004, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons++-- | Vi keymap for Yi.+-- Based on version 1.79 (7\/14\/97) of nex\/nvi+--+-- The goal is strict vi emulation++module Yi.Keymap.Vi ( keymap, ViMode ) where++import Yi.Yi+import Yi.Editor+-- import Yi.UI as UI+import Yi.History++import Prelude hiding ( any, error )++import Data.Char+import Data.List ( (\\) )++import Control.Arrow ((+++))+import Control.Exception ( ioErrors, try, evaluate )++import Control.Monad.State++++-- ---------------------------------------------------------------------++type ViMode = ViProc ()++type ViProc a = (Interact Char) a++--+-- | Top level. Lazily consume all the input, generating a list of+-- actions, which then need to be forced+--+-- NB . if there is a (bad) exception, we'll lose any new bindings.. iorefs?+-- . also, maybe we shouldn't refresh automatically?+--+keymap :: Keymap+keymap = do write $ setWindowFillE '~'+ runVi cmd_mode++runVi :: ViMode -> Keymap+runVi = comap eventToChar++------------------------------------------------------------------------++-- The vi lexer is divided into several parts, roughly corresponding+-- to the different modes of vi. Each mode is in turn broken up into+-- separate lexers for each phase of key input in that mode.++-- | command mode consits of simple commands that take a count arg - the+-- count is stored in the lexer state. also the replace cmd, which+-- consumes one char of input, and commands that switch modes.+cmd_mode :: ViMode+cmd_mode = choice [cmd_eval,eval cmd_move,cmd2other,cmd_op]++eval :: ViProc Action -> ViMode+eval p = do a <- p; write a++--+-- | insert mode is either insertion actions, or the meta \ESC action+--+ins_mode :: ViMode+ins_mode = many' ins_char >> event '\ESC' >> return ()++--+-- | replace mode is like insert, except it performs writes, not inserts+--+rep_mode :: ViMode+rep_mode = many' rep_char >> event '\ESC' >> return ()++------------------------------------------------------------------------+--+-- A parser to accumulate digits.+-- typically what is needed for integer repetition arguments to commands+--+-- ToDo don't handle 0 properly+--+count :: ViProc (Maybe Int)+count = option Nothing (many1' (satisfy isDigit) >>= return . Just . read)++-- ---------------------------------------------------------------------+-- | Movement commands+--+-- The may be invoked directly, or sometimes as arguments to other+-- /operator/ commands (like d).+--+cmd_move :: ViProc Action+cmd_move = do+ cnt <- count+ let x = maybe 1 id cnt+ choice [event c >> return (a x) | (c,a) <- moveCmdFM] ++++ choice [do event c; c' <- anyButEsc; return (a x c') | (c,a) <- move2CmdFM] ++++ (do event 'G'; return $ case cnt of+ Nothing -> botE >> moveToSol+ Just n -> gotoLn n)+++--+-- movement commands+--+moveCmdFM :: [(Char, Int -> Action)]+moveCmdFM =+-- left/right+ [('h', left)+ ,('\^H', left)+ ,(keyBackspace, left)+ ,('\BS', left)+ ,('l', right)+ ,(' ', right)+ ,(keyHome, const firstNonSpaceE) -- vim does moveToSol+ ,('^', const firstNonSpaceE)+ ,('$', const moveToEol)+ ,('|', \i -> moveToSol >> rightOrEolE (i-1))++-- up/down+ ,('k', up)+ ,(keyUp, up)+ ,('\^P', up)+ ,('j', down)+ ,(keyDown, down)+ ,('\^J', down)+ ,('\^L', const refreshEditor)+ ,('\^N', down)+ ,('\r', down)++-- words+ -- ToDo these aren't quite right, but are nice and simple+ ,('w', \i -> replicateM_ i $ do+ moveWhileE (isAlphaNum) GoRight+ moveWhileE (not.isAlphaNum) GoRight )++ ,('b', \i -> replicateM_ i $ do+ moveWhileE (isAlphaNum) GoLeft+ moveWhileE (not.isAlphaNum) GoLeft )++-- text+ ,('{', prevNParagraphs)+ ,('}', nextNParagraphs)++-- misc+ ,('H', \i -> downFromTosB (i - 1))+ ,('M', const middleB)+ ,('L', \i -> upFromBosB (i - 1))++-- bogus entry+ ,('G', const (return ()))+ ]+ where+ left i = leftOrSolE i+ right i = rightOrEolE i+ up i = if i > 100 then gotoLnFromE (-i) else replicateM_ i (execB Move VLine Backward)+ down i = if i > 100 then gotoLnFromE i else replicateM_ i (execB Move VLine Forward)++--+-- more movement commands. these ones are paramaterised by a character+-- to find in the buffer.+--+move2CmdFM :: [(Char, Int -> Char -> Action)]+move2CmdFM =+ [('f', \i c -> replicateM_ i $ rightB >> moveWhileE (/= c) GoRight)+ ,('F', \i c -> replicateM_ i $ leftB >> moveWhileE (/= c) GoLeft)+ ,('t', \i c -> replicateM_ i $ rightB >> moveWhileE (/= c) GoRight >> leftB)+ ,('T', \i c -> replicateM_ i $ leftB >> moveWhileE (/= c) GoLeft >> rightB)+ ]++--+-- | Other command mode functions+--+cmd_eval :: ViMode+cmd_eval = do+ cnt <- count+ let i = maybe 1 id cnt+ choice [event c >> write (a i) | (c,a) <- cmdCmdFM ] ++++ (do event 'r'; c <- anyButEscOrDel; write (writeE c)) ++++ (events ">>" >> write (do replicateM_ i $ moveToSol >> mapM_ insertN " "+ firstNonSpaceE)) ++++ (events "<<" >> write (do moveToSol+ replicateM_ i $+ replicateM_ 4 $+ readB >>= \k ->+ when (isSpace k) deleteN 1+ firstNonSpaceE)) ++++ (events "ZZ" >> write (viWrite >> quitEditor))++ where anyButEscOrDel = oneOf $ any' \\ ('\ESC':delete')++--+-- cmd mode commands+--+cmdCmdFM :: [(Char, Int -> Action)]+cmdCmdFM =+ [('\^B', upScreensB)+ ,('\^F', downScreensB)+ ,('\^G', const viFileInfo)+ ,('\^W', const nextWinE)+ ,('\^Z', const suspendEditor)+ ,('D', killLineE)+ ,('J', const (moveToEol >> deleteN 1)) -- the "\n"+ ,('n', const (doSearch Nothing [] GoRight))++ ,('X', \i -> do p <- getSelectionMarkPointB+ leftOrSolE i+ q <- getSelectionMarkPointB -- how far did we really move?+ when (p-q > 0) $ deleteNE (p-q) )++ ,('x', \i -> do p <- getSelectionMarkPointB -- not handling eol properly+ rightOrEolE i+ q <- getSelectionMarkPointB+ gotoPointE p+ when (q-p > 0) $ deleteNE (q-p) )++ ,('p', (\_ -> getRegE >>= \s ->+ moveToEol >> insertN '\n' >>+ mapM_ insertN s >> moveToSol)) -- ToDo insertNE++ ,(keyPPage, upScreensB)+ ,(keyNPage, downScreensB)+ ,(keyLeft, leftOrSolE) -- not really vi, but fun+ ,(keyRight, rightOrEolE)+ ]++--+-- | So-called 'operators', which take movement actions as arguments.+--+-- How do we achive this? We look for the known operator chars+-- (op_char), followed by digits and one of the known movement commands.+-- We then consult the lexer table with digits++move_char, to see what+-- movement commands they correspond to. We then return an action that+-- performs the movement, and then the operator. For example, we 'd'+-- command stores the current point, does a movement, then deletes from+-- the old to the new point.+--+-- We thus elegantly achieve things like 2d4j (2 * delete down 4 times)+-- Lazy lexers - you know we're right (tm).+--+cmd_op :: ViMode+cmd_op = do+ cnt <- count+ let i = maybe 1 id cnt+ choice $ [events "dd" >> write (moveToSol >> killE >> deleteN 1),+ events "yy" >> write (readLnE >>= setRegE)] +++ [do event c; m <- cmd_move; write (a i m) | (c,a) <- opCmdFM]+ where+ -- | operator (i.e. movement-parameterised) actions+ opCmdFM :: [(Char,Int -> Action -> Action)]+ opCmdFM =+ [('d', \i m -> replicateM_ i $ do+ (p,q) <- withPointMove m+ deleteNE (max 0 (abs (q - p) + 1)) -- inclusive+ ),+ ('y', \_ m -> do (p,q) <- withPointMove m+ s <- (if p < q then readNM p q else readNM q p)+ setRegE s -- ToDo registers not global.+ )+ ,('~', const invertCase) -- not right.+ ]++ -- invert the case of range described by movement @m@+ -- could take 90s on a 64M file.+ invertCase m = do+ (p,q) <- withPointMove m+ mapRangeE (min p q) (max p q) $ \c ->+ if isUpper c then toLower c else toUpper c++ --+ -- A strange, useful action. Save the current point, move to+ -- some xlocation specified by the sequence @m@, then return.+ -- Return the current, and remote point.+ --+ withPointMove :: Action -> EditorM (Int,Int)+ withPointMove m = do p <- getSelectionMarkPointB+ m+ q <- getSelectionMarkPointB+ when (p < q) $ gotoPointE p+ return (p,q)+++--+-- | Switch to another vi mode.+--+-- These commands transfer control to another+-- process. Some of these commands also perform an action before switching.+--+cmd2other :: ViMode+cmd2other = do c <- modeSwitchChar+ case c of+ ':' -> ex_mode ":"+ 'R' -> rep_mode+ 'i' -> ins_mode+ 'I' -> write moveToSol >> ins_mode+ 'a' -> write (rightOrEolE 1) >> ins_mode+ 'A' -> write moveToEol >> ins_mode+ 'o' -> write (moveToEol >> insertN '\n') >> ins_mode+ 'O' -> write (moveToSol >> insertN '\n' >> (execB Move VLine Backward)) >> ins_mode+ 'c' -> write (not_implemented 'c') >> ins_mode+ 'C' -> write (killLineE) >> ins_mode+ 'S' -> write (moveToSol >> readLnE >>= setRegE >> killE) >> ins_mode++ '/' -> ex_mode "/"++ '\ESC'-> write msgClr++ s -> write $ errorEditor ("The "++show s++" command is unknown.")+++ where modeSwitchChar = oneOf ":RiIaAoOcCS/?\ESC"++-- ---------------------------------------------------------------------+-- | vi insert mode+--+ins_char :: ViMode+ins_char = write . fn =<< anyButEsc+ where fn c = case c of+ k | isDel k -> leftB >> deleteN 1+ | k == keyPPage -> upScreenB+ | k == keyNPage -> downScreenB+ | k == '\t' -> mapM_ insertN " " -- XXX+ _ -> insertN c+++-- ---------------------------------------------------------------------+-- | vi replace mode+--+-- To quote vi:+-- In Replace mode, one character in the line is deleted for every character+-- you type. If there is no character to delete (at the end of the line), the+-- typed character is appended (as in Insert mode). Thus the number of+-- characters in a line stays the same until you get to the end of the line.+-- If a <NL> is typed, a line break is inserted and no character is deleted.+--+-- ToDo implement the undo features+--++rep_char :: ViMode+rep_char = write . fn =<< anyButEsc+ where fn c = case c of+ k | isDel k -> leftB >> deleteN 1+ | k == keyPPage -> upScreenB+ | k == keyNPage -> downScreenB+ '\t' -> mapM_ insertN " " -- XXX+ '\r' -> insertN '\n'+ _ -> do e <- atEolE+ if e then insertN c else writeE c >> rightB++-- ---------------------------------------------------------------------+-- Ex mode. We also process regex searching mode here.++spawn_ex_buffer :: String -> Action+spawn_ex_buffer prompt = do+ initialBuffer <- getBuffer+ Just initialWindow <- getWindow+ -- The above ensures that the action is performed on the buffer that originated the minibuffer.+ let closeMinibuffer = do b <- getBuffer; closeWindow; deleteBuffer b+ anyButDelNlArrow = oneOf $ any' \\ (enter' ++ delete' ++ ['\ESC',keyUp,keyDown])+ ex_buffer_finish = do+ historyFinish+ lineString <- readAllE+ closeMinibuffer+-- UI.setWindow initialWindow+ switchToBufferE initialBuffer+ ex_eval (head prompt : lineString)+ ex_process :: ViMode+ ex_process =+ choice [do c <- anyButDelNlArrow; write $ insertNE [c],+ do enter; write ex_buffer_finish,+ do event '\ESC'; write closeMinibuffer,+ do delete; write bdeleteB,+ do event keyUp; write historyUp,+ do event keyDown; write historyDown]+ historyStart+ spawnMinibufferE prompt (const $ runVi $ forever ex_process) (return ())+++ex_mode :: String -> ViMode+ex_mode = write . spawn_ex_buffer++-- | eval an ex command to an Action, also appends to the ex history+ex_eval :: String -> Action+ex_eval cmd = do+ case cmd of+ -- regex searching+ ('/':pat) -> doSearch (Just pat) [] GoRight++ -- TODO: We give up on re-mapping till there exists a generic Yi mechanism to do so.++ -- add mapping to command mode+ (_:'m':'a':'p':' ':_cs) -> error "Not yet implemented."++ -- add mapping to insert mode+ (_:'m':'a':'p':'!':' ':_cs) -> error "Not yet implemented."++ -- unmap a binding from command mode+ (_:'u':'n':'m':'a':'p':' ':_cs) -> error "Not yet implemented."++ -- unmap a binding from insert mode+ (_:'u':'n':'m':'a':'p':'!':' ':_cs) -> error "Not yet implemented."+++ -- just a normal ex command+ (_:src) -> fn src++ -- can't happen, but deal with it+ [] -> (return ())++ where+ fn "" = msgClr++ fn s@(c:_) | isDigit c = do+ e <- lift $ try $ evaluate $ read s+ case e of Left _ -> errorEditor $ "The " ++show s++ " command is unknown."+ Right lineNum -> gotoLn lineNum++ fn "w" = viWrite+ fn ('w':' ':f) = viWriteTo f+ fn "q" = do+ b <- isUnchangedB+ if b then closeWindow+ else errorEditor $ "File modified since last complete write; "+++ "write or use ! to override."+ fn "q!" = closeWindow+ fn "$" = botE+ fn "wq" = viWrite >> closeWindow+ fn "n" = nextBufW+ fn "p" = prevBufW+ fn ('s':'p':_) = splitE+ fn ('e':' ':f) = fnewE f+ fn ('s':'/':cs) = viSub cs++ fn "reboot" = rebootE -- !+ fn "reload" = reloadEditor >> return () -- !++ fn s = errorEditor $ "The "++show s++ " command is unknown."+++------------------------------------------------------------------------++not_implemented :: Char -> Action+not_implemented c = errorEditor $ "Not implemented: " ++ show c++-- ---------------------------------------------------------------------+-- Misc functions++viFileInfo :: Action+viFileInfo =+ do bufInfo <- bufInfoB+ msgEditor $ showBufInfo bufInfo+ where+ showBufInfo :: BufferFileInfo -> String+ showBufInfo bufInfo = concat [ show $ bufInfoFileName bufInfo+ , " Line "+ , show $ bufInfoLineNo bufInfo+ , " ["+ , bufInfoPercent bufInfo+ , "]"+ ]+++-- | Try to write a file in the manner of vi\/vim+-- Need to catch any exception to avoid losing bindings+viWrite :: Action+viWrite = do+ mf <- fileNameE+ case mf of+ Nothing -> errorEditor "no file name associate with buffer"+ Just f -> do+ bufInfo <- bufInfoB+ let s = bufInfoFileName bufInfo+ let msg = msgEditor $ show f ++" "++show s ++ "C written"+ catchJustE ioErrors (fwriteToE f >> msg) (msgEditor . show)++-- | Try to write to a named file in the manner of vi\/vim+viWriteTo :: String -> Action+viWriteTo f = do+ let f' = (takeWhile (/= ' ') . dropWhile (== ' ')) f+ bufInfo <- bufInfoB+ let s = bufInfoFileName bufInfo+ let msg = msgEditor $ show f'++" "++show s ++ "C written"+ catchJustE ioErrors (fwriteToE f' >> msg) (msgEditor . show)+++-- | Try to do a substitution+viSub :: [Char] -> Action+viSub cs = do+ let (pat,rep') = break (== '/') cs+ (rep,opts) = case rep' of+ [] -> ([],[])+ (_:ds) -> case break (== '/') ds of+ (rep'', []) -> (rep'', [])+ (rep'', (_:fs)) -> (rep'',fs)+ case opts of+ [] -> do_single pat rep+ ['g'] -> do_single pat rep+ _ -> do_single pat rep-- TODO++ where do_single p r = do+ s <- searchAndRepLocal p r+ if not s then errorEditor ("Pattern not found: "++p) else msgClr++{-+ -- inefficient. we recompile the regex each time.+ -- stupido+ do_line p r = do+ let loop i = do s <- searchAndRepLocal p r+ if s then loop (i+1) else return i+ s <- loop (0 :: Int)+ if s == 0 then msgEditor ("Pattern not found: "++p) else msgClr+-}++-- ---------------------------------------------------------------------+-- | Handle delete chars in a string+--+{-+clean :: [Char] -> [Char]+clean (_:c:cs) | isDel c = clean cs+clean (c:cs) | isDel c = clean cs+clean (c:cs) = c : clean cs+clean [] = []+-}++-- | Is a delete sequence+isDel :: Char -> Bool+isDel '\BS' = True+isDel '\127' = True+isDel c | c == keyBackspace = True+isDel _ = False++-- ---------------------------------------------------------------------+-- | character ranges+--+delete, enter, anyButEsc :: ViProc Char+enter = oneOf enter'+delete = oneOf delete'+anyButEsc = oneOf $ (keyBackspace : any' ++ cursc') \\ ['\ESC']++enter', any', delete' :: [Char]+enter' = ['\n', '\r']+delete' = ['\BS', '\127', keyBackspace ]+any' = ['\0' .. '\255']++cursc' :: [Char]+cursc' = [keyPPage, keyNPage, keyLeft, keyRight, keyDown, keyUp]
+ Yi/Keymap/Vim.hs view
@@ -0,0 +1,790 @@+{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}++--+-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--+++-- | Vim keymap for Yi. Emulates vim :set nocompatible+module Yi.Keymap.Vim ( keymap, VimMode, viWrite ) where++import Yi.Yi+import Yi.Style as Style+import Prelude hiding ( any, error )++import Data.Char+import Data.Maybe ( fromMaybe )+import Data.Dynamic+import qualified Data.Map as M++import Control.Exception ( ioErrors, try, evaluate )+import Control.Monad.State++import Yi.Editor+import Yi.Accessor+import Yi.History+import Yi.Buffer+import Yi.Debug++import Yi.Indent++import Yi.Keymap.Emacs.Utils (completeFileName,completeBufferName)+import Yi.MiniBuffer+import Yi.TextCompletion+import Yi.Syntax.Table (highlighters)++--+-- What's missing?+-- fancier :s//+-- '.'+-- movement parameterised \> \<+--++{-+ For now we just make the selected style the same as the+ modeline_focused style... Just because i'm not good with+ styles yet - Jim+-}+defaultVimUiStyle :: Style.UIStyle+defaultVimUiStyle = Style.uiStyle { selected = Style.modeline_focused Style.uiStyle}++-- ---------------------------------------------------------------------++type VimMode = VimProc ()++type VimProc a = (Interact Char) a+++-- | Top level+keymap :: Keymap+keymap = do write $ do setWindowFillE '~'+ withBuffer0 unsetMarkB+ setWindowStyleE defaultVimUiStyle+ runVim cmd_mode++runVim :: VimMode -> Keymap+runVim = comap eventToChar++------------------------------------------------------------------------++-- The Vim VimProc is divided into several parts, roughly corresponding+-- to the different modes of vi. Each mode is in turn broken up into+-- separate VimProcs for each phase of key input in that mode.++-- | Command mode consists of simple commands that take a count arg,+-- the replace cmd, which consumes one char of input, and commands+-- that switch modes.+cmd_mode :: VimMode+cmd_mode = choice [cmd_eval,eval cmd_move,cmd2other,cmd_op]++-- | Take a VimMode that returns and action; "run" it and write the returned action.+eval :: YiAction a () => VimProc (b, a) -> VimMode+eval p = do (_, a) <- p; write a++-- | Leave a mode. This always has priority over catch-all actions inside the mode.+leave :: VimMode+leave = event '\ESC' >> adjustPriority (-1) (write msgClr)++-- | Insert mode is either insertion actions, or the meta (\ESC) action+ins_mode :: VimMode+ins_mode = write (msgEditor "-- INSERT --") >> many (ins_char <|> kwd_mode) >> leave++-- | Replace mode is like insert, except it performs writes, not inserts+rep_mode :: VimMode+rep_mode = write (msgEditor "-- REPLACE --") >> many rep_char >> leave++-- | Visual mode, similar to command mode+vis_mode :: RegionStyle -> VimMode+vis_mode regionStyle = do+ write (withBuffer (pointB >>= setSelectionMarkPointB))+ core_vis_mode regionStyle+ write (msgClr >> withBuffer unsetMarkB >> withBuffer (setDynamicB $ SelectionStyle Character))++core_vis_mode :: RegionStyle -> VimMode+core_vis_mode regionStyle = do+ write $ withEditor $ do setA regionStyleA regionStyle+ withBuffer0 $ setDynamicB $ SelectionStyle $+ case regionStyle of { LineWise -> fullLine; CharWise -> Character }+ printMsg $ msg regionStyle+ many (eval cmd_move)+ (vis_single regionStyle <|| vis_multi)+ where msg CharWise = "-- VISUAL --"+ msg LineWise = "-- VISUAL LINE --"++-- | Change visual mode+change_vis_mode :: RegionStyle -> RegionStyle -> VimMode+change_vis_mode src dst | src == dst = return ()+change_vis_mode _ dst = core_vis_mode dst++-- | A VimProc to accumulate digits.+-- typically what is needed for integer repetition arguments to commands+count :: VimProc (Maybe Int)+count = option Nothing $ do+ c <- satisfy isDigitNon0+ cs <- many (satisfy isDigit)+ return $ Just $ read (c:cs)+ where isDigitNon0 '0' = False+ isDigitNon0 x = isDigit x++data RegionStyle = LineWise+ | CharWise+ deriving (Eq, Typeable, Show)++instance Initializable RegionStyle where+ initial = CharWise++regionStyleToUnit :: RegionStyle -> TextUnit+regionStyleToUnit LineWise = fullLine+regionStyleToUnit CharWise = Character++fullLine :: TextUnit+fullLine = GenUnit {genEnclosingUnit=Document, genUnitBoundary=bound}+ where bound d = withOffset d $ atBoundaryB Line d+ withOffset Backward f = f+ withOffset Forward f = savingPointB (leftB >> f)++regionStyleA :: Accessor Editor RegionStyle+regionStyleA = dynamicValueA .> dynamicA++-- ---------------------------------------------------------------------+-- | VimProc for movement commands+--+-- The may be invoked directly, or sometimes as arguments to other+-- /operator/ commands (like d).+--++cmd_move :: VimProc (RegionStyle, BufferM ())+cmd_move = do+ cnt <- count+ let x = maybe 1 id cnt+ choice ([event c >> return (CharWise, a x) | (c,a) <- moveCmdFM, (c /= '0' || Nothing == cnt) ] +++ [event c >> return (LineWise, a x) | (c,a) <- moveUpDownCmdFM] +++ [do event c; c' <- anyEvent; return (CharWise, a x c') | (c,a) <- move2CmdFM] +++ [do event 'G'; return (LineWise, case cnt of+ Nothing -> botB >> moveToSol+ Just n -> gotoLn n >> return ())+ ,do events "gg"; return (LineWise, gotoLn 0 >> return ())+ ,do events "ge"; return (CharWise, replicateM_ x $ genMoveB ViWord (Forward, InsideBound) Backward)])++-- | movement commands+moveCmdFM :: [(Char, Int -> BufferM ())]+moveCmdFM =+-- left/right+ [('h', left)+ ,('\^H', left)+ ,(keyBackspace, left)+ ,('\BS', left)+ ,('\127', left)+ ,(keyLeft, left)+ ,(keyRight, right)+ ,('l', right)+ ,(' ', right)+ ,(keyHome, sol)+ ,('0', sol)+ ,('^', const firstNonSpaceB)+ ,('$', eol)+ ,(keyEnd, eol)+ ,('|', \i -> moveToSol >> moveXorEol (i-1))++-- words+ ,('w', \i -> replicateM_ i $ genMoveB ViWord (Backward,InsideBound) Forward)+ ,('b', \i -> replicateM_ i $ genMoveB ViWord (Backward,InsideBound) Backward)+ ,('e', \i -> replicateM_ i $ genMoveB ViWord (Forward, InsideBound) Forward)++-- text+ ,('{', prevNParagraphs)+ ,('}', nextNParagraphs)++-- misc+ ,('H', \i -> downFromTosB (i - 1))+ ,('M', const middleB)+ ,('L', \i -> upFromBosB (i - 1))+ ]+ where+ left = moveXorSol+ right = moveXorEol+ sol _ = moveToSol+ eol _ = moveToEol++-- | up/down movement commands. these one are separated from moveCmdFM+-- because they behave differently when yanking/cuting (line mode).+moveUpDownCmdFM :: [(Char, Int -> BufferM ())]+moveUpDownCmdFM =+ [('k', up)+ ,(keyUp, up)+ ,('\^P', up)+ ,('j', down)+ ,(keyDown, down)+ ,('\^J', down)+ ,('\^N', down)+ ,('\r', down)+ ]+ where+ up i = lineMoveRel (-i) >> return ()+ down i = lineMoveRel i >> return ()++-- | more movement commands. these ones are paramaterised by a character+-- to find in the buffer.+move2CmdFM :: [(Char, Int -> Char -> BufferM ())]+move2CmdFM =+ [('f', \i c -> replicateM_ i $ nextCInc c)+ ,('F', \i c -> replicateM_ i $ prevCInc c)+ ,('t', \i c -> replicateM_ i $ nextCExc c)+ ,('T', \i c -> replicateM_ i $ prevCExc c)+ ]++-- | Other command mode functions+cmd_eval :: VimMode+cmd_eval = do+ cnt <- count+ let i = maybe 1 id cnt+ choice+ ([event c >> write (a i) | (c,a) <- singleCmdFM ] +++ [events evs >> write (action i) | (evs, action) <- multiCmdFM ]) <|>+ (do event 'r'; c <- anyButEscOrDel; write (writeB c)) <|>+ (events ">>" >> write (shiftIndentOfLine i)) <|>+ (events "<<" >> write (shiftIndentOfLine (-i))) <|>+ (events "ZZ" >> write (viWrite >> quitEditor))++-- TODO: escape the current word+-- at word bounds: search for \<word\>+searchCurrentWord :: YiM ()+searchCurrentWord = do+ w <- withBuffer $ readRegionB =<< regionOfB ViWord+ doSearch (Just w) [] Forward++anyButEscOrDel :: VimProc Char+anyButEscOrDel = satisfy (not . (`elem` ('\ESC':delete')))++continueSearching :: Direction -> YiM ()+continueSearching direction = do+ withEditor $ getRegexE >>= printMsg . ("/" ++) . fst . fromMaybe ([],undefined)+ doSearch Nothing [] direction++-- | cmd mode commands+singleCmdFM :: [(Char, Int -> YiM ())]+singleCmdFM =+ [('\^B', withBuffer . upScreensB) -- vim does (firstNonSpaceB;moveXorSol)+ ,('\^F', withBuffer . downScreensB)+ ,('\^G', const viFileInfo) -- hmm. not working. duh. we clear+ ,('\^L', const refreshEditor)+ ,('\^R', withBuffer . flip replicateM_ redoB)+ ,('\^Z', const suspendEditor)+ ,('D', const (withEditor $ withBuffer0 readRestOfLnB >>= setRegE >> withBuffer0 deleteToEol))+ ,('J', const (withBuffer (moveToEol >> deleteN 1))) -- the "\n"+ ,('U', withBuffer . flip replicateM_ undoB) -- NB not correct+ ,('n', const $ continueSearching Forward)+ ,('u', withBuffer . flip replicateM_ undoB)++ ,('X', \i -> withBuffer $ do p <- pointB+ moveXorSol i+ q <- pointB+ when (p-q > 0) $ deleteN (p-q) )++ ,('x', \i -> withBuffer $ do p <- pointB -- not handling eol properly+ moveXorEol i+ q <- pointB+ moveTo p+ when (q-p > 0) $ deleteN (q-p))++ ,('p', withEditor . flip replicateM_ pasteAfter)++ ,('P', withEditor . flip replicateM_ pasteBefore)++ ,(keyPPage, withBuffer . upScreensB)+ ,(keyNPage, withBuffer . downScreensB)+ ,('*', const $ searchCurrentWord)+ ,('~', \i -> withBuffer $ do+ p <- pointB+ moveXorEol i+ q <- pointB+ moveTo p+ mapRegionB (mkRegion p q) $ \c ->+ if isUpper c then toLower c else toUpper c+ moveTo q)+ ]++multiCmdFM :: [(String, Int -> YiM ())]+multiCmdFM =+ [("\^Wc", const $ withEditor tryCloseE)+ ,("\^Wo", const $ withEditor closeOtherE)+ ,("\^Ws", const $ withEditor splitE)+ ,("\^Ww", const $ withEditor nextWinE)+ ,("\^WW", const $ withEditor prevWinE)+ ,("\^Wp", const $ withEditor prevWinE)++ -- since we don't have vertical splitting,+ -- these moving can be done using next/prev.+ ,(['\^W',keyDown], const $ withEditor nextWinE)+ ,(['\^W',keyUp], const $ withEditor prevWinE)+ ,(['\^W',keyRight], const $ withEditor nextWinE)+ ,(['\^W',keyLeft], const $ withEditor prevWinE)+ ]++-- | So-called 'operators', which take movement actions as arguments.+--+-- How do we achive this? We parse a known operator char then parse+-- one of the known movement commands. We then apply the returned+-- action and then the operator. For example, we 'd' command stores+-- the current point, does a movement, then deletes from the old to+-- the new point.+cmd_op :: VimMode+cmd_op = do+ cnt <- count+ let i = maybe 1 id cnt+ choice $ [events "dd" >> write (cut pointB (lineMoveRel (i-1) >> return ()) LineWise),+ events "yy" >> write (yank pointB (lineMoveRel (i-1) >> return ()) LineWise)] +++ [do event c+ (regionStyle, m) <- cmd_move+ write $ a (replicateM_ i m) regionStyle+ | (c,a) <- opCmdFM]+ where+ -- | operator (i.e. movement-parameterised) actions+ opCmdFM :: [(Char, BufferM () -> RegionStyle -> EditorM ())]+ opCmdFM =+ [('d', cut pointB),+ ('y', yank pointB)]++regionFromTo :: BufferM Point -> BufferM () -> RegionStyle -> BufferM Region+regionFromTo mstart move regionStyle = do+ start <- mstart+ move+ stop <- pointB+ let region = mkRegion start stop+ unitWiseRegion (regionStyleToUnit regionStyle) region++yank :: BufferM Point -> BufferM () -> RegionStyle -> EditorM ()+yank mstart move regionStyle = do+ txt <- withBuffer0 $ do+ p <- pointB+ region <- regionFromTo mstart move regionStyle+ moveTo p+ readRegionB region+ setRegE $ if (regionStyle /= CharWise) then '\n':txt else txt+ let rowsYanked = length (filter (== '\n') txt)+ when (rowsYanked > 2) $ printMsg $ (show rowsYanked) ++ " lines yanked"++cut :: BufferM Point -> BufferM () -> RegionStyle -> EditorM ()+cut mstart move regionStyle = do+ txt <- withBuffer0 $ do+ region <- regionFromTo mstart move regionStyle+ txt <- readRegionB region+ deleteRegionB region+ return txt+ setRegE $ if (regionStyle /= CharWise) then '\n':txt else txt+ let rowsCut = length (filter (== '\n') txt)+ when (rowsCut > 2) $ printMsg ( (show rowsCut) ++ " fewer lines")++cutSelection :: EditorM ()+cutSelection = cut getSelectionMarkPointB (return ()) =<< getA regionStyleA++yankSelection :: EditorM ()+yankSelection = yank getSelectionMarkPointB (return ()) =<< getA regionStyleA++pasteOverSelection :: EditorM ()+pasteOverSelection = do+ txt <- getRegE+ regionStyle <- getA regionStyleA+ withBuffer0 $ do+ region <- regionFromTo getSelectionMarkPointB (return ()) regionStyle+ moveTo $ regionStart region+ deleteRegionB region+ insertN txt++pasteAfter :: EditorM ()+pasteAfter = do+ txt' <- getRegE+ withBuffer0 $+ case txt' of+ '\n':txt -> moveToEol >> rightB >> insertN txt >> leftN (length txt)+ _ -> moveXorEol 1 >> insertN txt' >> leftB++pasteBefore :: EditorM ()+pasteBefore = do+ txt' <- getRegE+ withBuffer0 $ do+ case txt' of+ '\n':txt -> moveToSol >> insertN txt >> leftN (length txt)+ _ -> insertN txt' >> leftB++-- | Switching to another mode from visual mode.+--+-- All visual commands are meta actions, as they transfer control to another+-- VimProc. In this way vis_single is analogous to cmd2other+--+vis_single :: RegionStyle -> VimMode+vis_single regionStyle =+ let beginIns a = do write (a >> withBuffer0 unsetMarkB) >> ins_mode+ in choice [+ event '\ESC' >> return (),+ event 'V' >> change_vis_mode regionStyle LineWise,+ event 'v' >> change_vis_mode regionStyle CharWise,+ event ':' >> ex_mode ":'<,'>",+ event 'y' >> write yankSelection,+ event 'x' >> write cutSelection,+ event 'd' >> write cutSelection,+ event 'p' >> write pasteOverSelection,+ event 'c' >> beginIns cutSelection]+++-- | These also switch mode, as all visual commands do, but these are+-- analogous to the commands in cmd_eval. They are different in that+-- they are multiple characters+vis_multi :: VimMode+vis_multi = do+ cnt <- count+ let i = maybe 1 id cnt+ choice ([events "ZZ" >> write (viWrite >> quitEditor),+ events ">>" >> write (shiftIndentOfSelection i),+ events "<<" >> write (shiftIndentOfSelection (-i)),+ do event 'r'; x <- anyEvent; write $ do+ mrk <- getSelectionMarkPointB+ pt <- pointB+ text <- readRegionB (mkVimRegion mrk pt)+ moveTo mrk+ deleteRegionB (mkVimRegion mrk pt)+ let convert '\n' = '\n'+ convert _ = x+ insertN $ map convert $ text] +++ [event c >> write (a i) | (c,a) <- singleCmdFM ])+++-- | Switch to another vim mode from command mode.+--+-- These commands are meta actions, as they transfer control to another+-- VimProc. Some of these commands also perform an action before switching.+--+cmd2other :: VimMode+cmd2other = let beginIns a = write a >> ins_mode+ beginIns :: EditorM () -> VimMode+ in choice [+ do event ':' ; ex_mode ":",+ do event 'v' ; vis_mode CharWise,+ do event 'V' ; vis_mode LineWise,+ do event 'R' ; rep_mode,+ do event 'i' ; ins_mode,+ do event 'I' ; beginIns (withBuffer0 moveToSol),+ do event 'a' ; beginIns $ withBuffer0 $ moveXorEol 1,+ do event 'A' ; beginIns (withBuffer0 moveToEol),+ do event 'o' ; beginIns $ withBuffer0 $ moveToEol >> insertB '\n',+ do event 'O' ; beginIns $ withBuffer0 $ moveToSol >> insertB '\n' >> lineUp,+ do event 'c' ; (regionStyle, m) <- cmd_move ; beginIns $ cut pointB m regionStyle,+ do events "cc" ; beginIns $ cut (moveToSol >> pointB) moveToEol CharWise,+ do event 'C' ; beginIns $ cut pointB moveToEol CharWise, -- alias of "c$"+ do event 'S' ; beginIns $ cut (moveToSol >> pointB) moveToEol CharWise, -- alias of "cc"+ do event 's' ; beginIns $ cut pointB (moveXorEol 1) CharWise, -- alias of "cl"+ do event '/' ; ex_mode "/",+ do event '?' ; write $ not_implemented '?',+ leave,+ do event keyIC ; ins_mode]+++ins_mov_char :: VimMode+ins_mov_char = choice [event keyPPage >> write upScreenB,+ event keyNPage >> write downScreenB,+ event keyUp >> write lineUp,+ event keyDown >> write lineDown,+ event keyLeft >> write (moveXorSol 1),+ event keyRight >> write (moveXorEol 1),+ event keyEnd >> write moveToEol,+ event keyHome >> write moveToSol]+++-- ---------------------------------------------------------------------+-- | vim insert mode+--+-- Some ideas for a better insert mode are contained in:+--+-- Poller and Garter , "A comparative study of moded and modeless+-- text editing by experienced editor users", 1983+--+-- which suggest that movement commands be added to insert mode, along+-- with delete.+--+ins_char :: VimMode+ins_char = choice [satisfy isDel >> write (deleteB Character Backward),+ event keyDC >> write (deleteB Character Forward),+ event '\t' >> write insertTabB]+ <|> ins_mov_char+ <|| do c <- anyEvent; write (insertB c)++-- --------------------+-- | Keyword+kwd_mode :: VimMode+kwd_mode = some (event '\^N' >> adjustPriority (-1) (write wordCompleteB)) >> (write resetCompleteB)+ -- 'adjustPriority' is there to lift the ambiguity between "continuing" completion+ -- and resetting it (restarting at the 1st completion).++-- ---------------------------------------------------------------------+-- | vim replace mode+--+-- To quote vim:+-- In Replace mode, one character in the line is deleted for every character+-- you type. If there is no character to delete (at the end of the line), the+-- typed character is appended (as in Insert mode). Thus the number of+-- characters in a line stays the same until you get to the end of the line.+-- If a <NL> is typed, a line break is inserted and no character is deleted.+rep_char :: VimMode+rep_char = choice [satisfy isDel >> write leftB, -- should undo unless pointer has been moved+ event '\t' >> write (insertN " "),+ event '\r' >> write (insertB '\n')]+ <|> ins_mov_char+ <|| do c <- anyEvent; write (do e <- atEol; if e then insertB c else writeB c)++-- ---------------------------------------------------------------------+-- Ex mode. We also process regex searching mode here.++spawn_ex_buffer :: String -> YiM ()+spawn_ex_buffer prompt = do+ -- The above ensures that the action is performed on the buffer that originated the minibuffer.+ let ex_buffer_finish = do+ withEditor $ historyFinish+ lineString <- withBuffer elemsB+ withEditor closeBufferAndWindowE+ ex_eval (head prompt : lineString)+ ex_process :: VimMode+ ex_process =+ choice [enter >> write ex_buffer_finish,+ event '\t' >> write completeMinibuffer,+ event '\ESC' >> write closeBufferAndWindowE,+ delete >> write bdeleteB,+ event keyUp >> write historyUp,+ event keyDown >> write historyDown,+ event keyLeft >> write (moveXorSol 1),+ event keyRight >> write (moveXorEol 1)]+ <|| (do c <- anyEvent; write $ insertB c)+ completeMinibuffer = withBuffer elemsB >>= ex_complete >>= withBuffer . insertN+ b_complete f = completeBufferName f >>= return . drop (length f)+ ex_complete ('e':' ':f) = completeFileName Nothing f >>= return . drop (length f)+ ex_complete ('b':' ':f) = b_complete f+ ex_complete ('b':'u':'f':'f':'e':'r':' ':f) = b_complete f+ ex_complete ('b':'d':' ':f) = b_complete f+ ex_complete ('b':'d':'!':' ':f) = b_complete f+ ex_complete ('b':'d':'e':'l':'e':'t':'e':' ':f) = b_complete f+ ex_complete ('b':'d':'e':'l':'e':'t':'e':'!':' ':f) = b_complete f+ ex_complete _ = return ""++ withEditor $ historyStart+ spawnMinibufferE prompt (const $ runVim $ ex_process) (return ())+++ex_mode :: String -> VimMode+ex_mode = write . spawn_ex_buffer++-- | eval an ex command to an YiM (), also appends to the ex history+ex_eval :: String -> YiM ()+ex_eval cmd = do+ case cmd of+ -- regex searching+ ('/':pat) -> doSearch (Just pat) [] Forward++ -- TODO: We give up on re-mapping till there exists a generic Yi mechanism to do so.++ -- add mapping to command mode+ (_:'m':'a':'p':' ':_cs) -> error "Not yet implemented."++ -- add mapping to insert mode+ (_:'m':'a':'p':'!':' ':_cs) -> error "Not yet implemented."++ -- unmap a binding from command mode+ (_:'u':'n':'m':'a':'p':' ':_cs) -> error "Not yet implemented."++ -- unmap a binding from insert mode+ (_:'u':'n':'m':'a':'p':'!':' ':_cs) -> error "Not yet implemented."+++ -- just a normal ex command+ (_:src) -> fn src++ -- can't happen, but deal with it+ [] -> return ()++ where+ whenUnchanged mu f = do u <- mu+ if u then f+ else errorEditor "No write since last change (add ! to override)"+ quitB = whenUnchanged (withBuffer isUnchangedB) closeWindow++ quitNoW = do bufs <- withEditor $ do closeBufferE ""+ bufs <- gets bufferStack+ mapM (\x -> withGivenBuffer0 x isUnchangedB) bufs+ whenUnchanged (return $ all id bufs) quitEditor++ quitall = withAllBuffers quitB+ wquitall = withAllBuffers viWrite >> quitEditor+ bdelete = whenUnchanged (withBuffer isUnchangedB) . withEditor . closeBufferE+ bdeleteNoW = withEditor . closeBufferE++ fn "" = msgClr++ fn s@(c:_) | isDigit c = do+ e <- lift $ try $ evaluate $ read s+ case e of Left _ -> errorEditor $ "The " ++show s++ " command is unknown."+ Right lineNum -> withBuffer (gotoLn lineNum) >> return ()++ fn "w" = viWrite+ fn ('w':' ':f) = viWriteTo f+ fn "qa" = quitall+ fn "qal" = quitall+ fn "qall" = quitall+ fn "quita" = quitall+ fn "quital" = quitall+ fn "quitall" = quitall+ fn "q" = quitB+ fn "qu" = quitB+ fn "qui" = quitB+ fn "quit" = quitB+ fn "q!" = quitNoW+ fn "qu!" = quitNoW+ fn "qui!" = quitNoW+ fn "quit!" = quitNoW+ fn "qa!" = quitEditor+ fn "quita!" = quitEditor+ fn "quital!" = quitEditor+ fn "quitall!" = quitEditor+ fn "wq" = viWrite >> closeWindow+ fn "wqa" = wquitall+ fn "wqal" = wquitall+ fn "wqall" = wquitall+ fn "x" = do unchanged <- withBuffer isUnchangedB+ unless unchanged viWrite+ closeWindow+ fn "n" = withEditor nextBufW+ fn "next" = withEditor nextBufW+ fn "$" = withBuffer botB+ fn "p" = withEditor prevBufW+ fn "prev" = withEditor prevBufW+ fn ('s':'p':_) = withEditor splitE+ fn "e" = revertE+ fn ('e':' ':f) = fnewE 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) = viSub cs++ fn ('b':' ':"m") = withEditor $ switchToBufferWithNameE "*messages*"+ fn ('b':' ':f) = withEditor $ switchToBufferWithNameE f+ fn "bd" = bdelete ""+ fn "bdelete" = bdelete ""+ fn ('b':'d':' ':f) = bdelete f+ fn ('b':'d':'e':'l':'e':'t':'e':' ':f) = bdelete f+ fn "bd!" = bdeleteNoW ""+ fn "bdelete!" = bdeleteNoW ""+ fn ('b':'d':'!':' ':f) = bdeleteNoW f+ fn ('b':'d':'e':'l':'e':'t':'e':'!':' ':f) = bdeleteNoW f+ -- TODO: bd[!] [N]++ -- send just this line through external command /fn/+ fn ('.':'!':f) = do+ ln <- withBuffer readLnB+ ln' <- runProcessWithInput f ln+ withBuffer $ do moveToSol+ deleteToEol+ insertN ln'+ moveToSol++-- Needs to occur in another buffer+-- fn ('!':f) = runProcessWithInput f []++ fn "reload" = reloadEditor >> return () -- not in vim+ fn "eval" = withBuffer (regionOfB Document >>= readRegionB) >>= evalE -- not in vim++ fn "redr" = refreshEditor+ fn "redraw" = refreshEditor++ fn "u" = withBuffer undoB+ fn "undo" = withBuffer undoB+ fn "r" = withBuffer redoB+ fn "redo" = withBuffer redoB++ fn "sus" = suspendEditor+ fn "suspend" = suspendEditor+ fn "st" = suspendEditor+ fn "stop" = suspendEditor++ fn s = errorEditor $ "The "++show s++ " command is unknown."+++------------------------------------------------------------------------++not_implemented :: Char -> YiM ()+not_implemented c = errorEditor $ "Not implemented: " ++ show c++-- ---------------------------------------------------------------------+-- Misc functions++withAllBuffers :: YiM () -> YiM ()+withAllBuffers m = mapM_ (\b -> withEditor (setBuffer b) >> m) =<< readEditor bufferStack++viFileInfo :: YiM ()+viFileInfo =+ do bufInfo <- withBuffer bufInfoB+ msgEditor $ showBufInfo bufInfo+ where+ showBufInfo :: BufferFileInfo -> String+ showBufInfo bufInfo = concat [ show $ bufInfoFileName bufInfo+ , " Line "+ , show $ bufInfoLineNo bufInfo+ , " ["+ , bufInfoPercent bufInfo+ , "]"+ ]+++-- | Try to write a file in the manner of vi\/vim+-- Need to catch any exception to avoid losing bindings+viWrite :: YiM ()+viWrite = do+ mf <- withBuffer getfileB+ case mf of+ Nothing -> errorEditor "no file name associate with buffer"+ Just f -> do+ bufInfo <- withBuffer bufInfoB+ let s = bufInfoFileName bufInfo+ let msg = msgEditor $ show f ++" "++show s ++ "C written"+ catchJustE ioErrors (fwriteToE f >> msg) (msgEditor . show)+++-- | Try to write to a named file in the manner of vi\/vim+viWriteTo :: String -> YiM ()+viWriteTo f = do+ let f' = (takeWhile (/= ' ') . dropWhile (== ' ')) f+ bufInfo <- withBuffer bufInfoB+ let s = bufInfoFileName bufInfo+ let msg = msgEditor $ show f'++" "++show s ++ "C written"+ catchJustE ioErrors (fwriteToE f' >> msg) (msgEditor . show)++-- | Try to do a substitution+viSub :: [Char] -> YiM ()+viSub cs = do+ let (pat,rep') = break (== '/') cs+ (rep,opts) = case rep' of+ [] -> ([],[])+ (_:ds) -> case break (== '/') ds of+ (rep'', []) -> (rep'', [])+ (rep'', (_:fs)) -> (rep'',fs)+ case opts of+ [] -> do_single pat rep+ ['g'] -> do_single pat rep+ _ -> do_single pat rep-- TODO++ where do_single p r = do+ s <- searchAndRepLocal p r+ if not s then errorEditor ("Pattern not found: "++p) else msgClr++-- | Is a delete sequence+isDel :: Char -> Bool+isDel '\BS' = True+isDel '\127' = True+isDel c | c == keyBackspace = True+isDel _ = False++-- ---------------------------------------------------------------------+-- | Character ranges+--+delete, enter :: VimProc Char+enter = oneOf ['\n', '\r']+delete = oneOf delete'++delete' :: [Char]+delete' = ['\BS', '\127', keyBackspace ]
+ Yi/KillRing.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Copyright (c) 2005,8 Jean-Philippe Bernardy++++module Yi.KillRing (Killring+ ,krKilled+ ,krContents+ ,krEndCmd+ ,krPut+ ,krEmpty+ ) + where+++data Killring = Killring { krKilled :: Bool+ , krAccumulate :: Bool+ , krContents :: [String]+ , krLastYank :: Bool+ }+ deriving (Show)++maxDepth :: Int+maxDepth = 10++krEmpty :: Killring+krEmpty = Killring { krKilled = False+ , krAccumulate = False+ , krContents = [[]]+ , krLastYank = False+ }+++-- | Finish an atomic command, for the purpose of killring accumulation.+krEndCmd :: Killring -> Killring+krEndCmd kr@Killring {krKilled = killed} = kr {krKilled = False, krAccumulate = killed }++-- | Put some text in the killring.+-- It's accumulated if the last command was a kill too+krPut :: String -> Killring -> Killring+krPut s kr@Killring {krContents = r@(x:xs), krAccumulate=acc}+ = kr {krKilled = True,+ krContents = if acc then (x++s):xs+ else s:take maxDepth r }+krPut _ _ = error "killring invariant violated"
+ Yi/Main.hs view
@@ -0,0 +1,177 @@++-- 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.+--++module Yi.Main (main, Kernel) where++import Prelude hiding (error)++import qualified Yi.Core as Core+import qualified Yi.Dired as Dired+import qualified Yi.Buffer as Buffer+import qualified Yi.Keymap as Keymap+import qualified Yi.Eval as Eval+import qualified Yi.Editor as Editor+import qualified Yi.Keymap.Emacs as Emacs+import qualified Yi.Keymap.Vim as Vim+import Yi.UI.Common (UIBoot)+import Yi.Kernel+import Yi.Debug++import Yi.Interact hiding (write)++#ifdef FRONTEND_COCOA+import qualified Yi.UI.Cocoa+import Foundation (withAutoreleasePool)+#endif+#ifdef FRONTEND_GTK+import qualified Yi.UI.Gtk+#endif+#ifdef FRONTEND_VTY+import qualified Yi.UI.Vty+#endif++import Data.Char+import Data.List ( intersperse )++import System.Console.GetOpt+import System.Environment ( getArgs )+import System.Exit++#include "ghcconfig.h"+++frontends :: [(String,UIBoot)]+frontends =+#ifdef FRONTEND_COCOA+ ("cocoa", Yi.UI.Cocoa.start) :+#endif+#ifdef FRONTEND_GTK+ ("gtk", Yi.UI.Gtk.start) :+#endif+#ifdef FRONTEND_VTY+ ("vty", Yi.UI.Vty.start) :+#endif+ []++frontendNames :: [String]+frontendNames = map fst' frontends+ where fst' :: (a,UIBoot) -> a+ fst' (x,_) = x++-- ---------------------------------------------------------------------+-- | Argument parsing. Pretty standard.++data Opts = Help+ | Version+ | OptIgnore String+ | LineNo String+ | EditorNm String+ | File String+ | Frontend String+ | ConfigFile String++-- | List of editors for which we provide an emulation.+editors :: [(String,Keymap.Keymap)]+editors = [("emacs", Emacs.keymap),+ ("vim", Vim.keymap)]++options :: [OptDescr Opts]+options = [+ Option ['f'] ["frontend"] (ReqArg Frontend "[frontend]")+ ("Select frontend, which can be one of:\n" +++ (concat . intersperse ", ") frontendNames),+ Option ['y'] ["config-file"] (ReqArg ConfigFile "path") "Specify a configuration file",+ Option ['V'] ["version"] (NoArg Version) "Show version information",+ Option ['B'] ["libdir"] (ReqArg OptIgnore "libdir") "Path to runtime libraries",+ Option ['b'] ["bindir"] (ReqArg OptIgnore "bindir") "Path to runtime library binaries\n(default: libdir)",+ Option ['h'] ["help"] (NoArg Help) "Show this help",+ Option ['l'] ["line"] (ReqArg LineNo "[num]") "Start on line number",+ Option [] ["as"] (ReqArg EditorNm "[editor]")+ ("Start with editor keymap, where editor is one of:\n" +++ (concat . intersperse ", " . map fst) editors)+ ]++-- | usage string.+usage, versinfo :: IO ()+usage = putStr $ usageInfo "Usage: yi [option...] [file]" options++versinfo = putStrLn $ "yi 0.3.0"+-- TODO: pull this out of the cabal configuration++-- | deal with real options+do_opt :: Opts -> IO (Keymap.YiM ())+do_opt o = case o of+ Frontend f -> case map toLower f `elem` frontendNames of+ False -> do putStrLn ("Unknown frontend: " ++ show f)+ exitWith (ExitFailure 1)+ _ -> return (return ()) -- Processed differently+ OptIgnore _ -> return (return ())+ ConfigFile _ -> return (return ())+ Help -> usage >> exitWith ExitSuccess+ Version -> versinfo >> exitWith ExitSuccess+ LineNo l -> return (Keymap.withBuffer (Buffer.gotoLn (read l)) >> return ())+ File file -> return (Dired.fnewE file)+ EditorNm emul -> case lookup (map toLower emul) editors of+ Just km -> return $ Core.changeKeymap km+ Nothing -> do putStrLn ("Unknown emulation: " ++ show emul)+ exitWith (ExitFailure 1)++-- | everything that is left over+do_args :: [String] -> IO (Core.StartConfig, [Keymap.YiM ()])+do_args args =+ case (getOpt (ReturnInOrder File) options args) of+ (o, [], []) -> do+ let frontend = head $ [f | Frontend f <- o] ++ [head frontendNames]+ yiConfig = head $ [f | ConfigFile f <- o] ++ ["YiConfig"]+ config = Core.StartConfig { Core.startFrontEnd = case lookup frontend frontends of+ Nothing -> error "Panic: frontend not found"+ Just x -> x+ , Core.startConfigFile = yiConfig+ }+ actions <- mapM do_opt o+ return (config, actions)+ (_, _, errs) -> do putStrLn (concat errs)+ exitWith (ExitFailure 1)++startConsole :: Keymap.YiM ()+startConsole = do+ console <- Core.withEditor $ Editor.getBufferWithName "*console*"+ Keymap.setBufferKeymap console (Eval.consoleKeymap <||)++openScratchBuffer :: Keymap.YiM ()+openScratchBuffer = Core.withEditor $ do -- emacs-like behaviour+ Editor.newBufferE "*scratch*"+ ("-- This buffer is for notes you don't want to save, and for haskell evaluation\n" +++ "-- If you want to create a file, open that file,\n" +++ "-- then enter the text in that file's own buffer.\n\n")+ return ()++-- ---------------------------------------------------------------------+-- | Static main. This is the front end to the statically linked+-- application, and the real front end, in a sense. 'dynamic_main' calls+-- this after setting preferences passed from the boot loader.+--+main :: Kernel -> IO ()+#ifdef FRONTEND_COCOA+main kernel = withAutoreleasePool $ do+#else+main kernel = do+#endif+ (config, mopts) <- do_args =<< getArgs+ Core.startEditor config kernel Nothing (startConsole : openScratchBuffer : mopts)
+ Yi/MiniBuffer.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++ module Yi.MiniBuffer (+ spawnMinibufferE, withMinibuffer+) where++import Data.Typeable+import Yi.Buffer+import Yi.Buffer.Region+import Yi.Core+import Yi.Editor+import Yi.History+import Yi.Keymap+import Yi.Keymap.Emacs.Keys+import Yi.Window+import qualified Yi.Editor as Editor+import qualified Yi.WindowSet as WS+++-- | Open a minibuffer window with the given prompt and keymap+spawnMinibufferE :: String -> KeymapEndo -> YiM () -> YiM ()+spawnMinibufferE prompt kmMod initialAction =+ do b <- withEditor $ stringToNewBuffer prompt []+ setBufferKeymap b kmMod+ withEditor $ modifyWindows (WS.add $ Window True b 0 0 0)+ initialAction++-- | @withMinibuffer prompt completer act@: open a minibuffer with @prompt@. Once a string @s@ is obtained, run @act s@. @completer@ can be used to complete functions.+withMinibuffer :: String -> (String -> YiM String) -> (String -> YiM ()) -> YiM ()+withMinibuffer prompt completer act = do+ initialBuffer <- withEditor getBuffer+ let innerAction :: YiM ()+ -- ^ Read contents of current buffer (which should be the minibuffer), and+ -- apply it to the desired action+ closeMinibuffer = closeBufferAndWindowE+ innerAction = do+ lineString <- withEditor $ do historyFinish+ lineString <- withBuffer0 elemsB+ closeMinibuffer+ switchToBufferE initialBuffer+ -- The above ensures that the action is performed on the buffer+ -- that originated the minibuffer.+ return lineString+ act lineString+ rebindings = [("RET", write innerAction),+ ("C-m", write innerAction),+ ("M-p", write historyUp),+ ("M-n", write historyDown),+ ("<up>", write historyUp),+ ("<down>", write historyDown),+ ("C-i", write (completionFunction completer)),+ ("TAB", write (completionFunction completer)),+ ("C-g", write closeMinibuffer)]+ withEditor $ historyStart+ spawnMinibufferE (prompt ++ " ") (rebind rebindings) (return ())++completionFunction :: (String -> YiM String) -> YiM ()+completionFunction f = do+ p <- withBuffer pointB+ text <- withBuffer $ readRegionB $ mkRegion 0 p+ compl <- f text+ -- it's important to do this before removing the text,+ -- so if the completion function raises an exception, we don't delete the buffer contents.+ withBuffer $ do moveTo 0+ deleteN p+ insertN compl+++-- TODO: be a bit more clever than 'Read r'+instance (YiAction a x, Read r, Typeable r) => YiAction (r -> a) x where+ makeAction f = YiA $ withMinibuffer (show $ typeOf (undefined::r)) return $+ \string -> runAction $ makeAction $ f $ read string
+ Yi/MkTemp.hs view
@@ -0,0 +1,253 @@+--+-- glaexts for I# ops+--+-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- You should have received a copy of the GNU Lesser General Public+-- License along with this library; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307+-- USA+--++--+-- A Haskell reimplementation of the C mktemp/mkstemp/mkstemps library+-- based on the algorithms in:+-- > $ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $+-- which are available under the BSD license.+--++module Yi.MkTemp (++ mktemp, -- :: FilePath -> IO Maybe FilePath+ mkstemp, -- :: FilePath -> IO Maybe (FilePath, Handle)+ mkstemps, -- :: FilePath -> Int -> IO Maybe (FilePath,Handle)+ mkdtemp, -- :: FilePath -> IO Maybe FilePath++ ) where++#include "ghcconfig.h"++import Data.List+import Data.Char ( chr, ord, isDigit )+import Control.Monad ( liftM )+import Control.Exception ( handleJust )+import System.Directory ( doesDirectoryExist, doesFileExist, createDirectory )+import System.IO+import System.IO.Error ( isAlreadyExistsError )++import GHC.IOBase ( IOException(IOError),+ Exception(IOException),+ IOErrorType(AlreadyExists) )++#ifndef __MINGW32__+import qualified System.Posix.Internals ( c_getpid )+#endif++#ifdef HAVE_ARC4RANDOM+import GHC.Base hiding ( ord, chr )+import GHC.Int+#else+import System.Random ( getStdRandom, Random(randomR) )+#endif++------------------------------------------------------------------------++mkstemps :: FilePath -> Int -> IO (Maybe (FilePath,Handle))+mkstemp :: FilePath -> IO (Maybe (FilePath,Handle))+mktemp :: FilePath -> IO (Maybe FilePath)+mkdtemp :: FilePath -> IO (Maybe FilePath)++mkstemps path slen = gettemp path True False slen++mkstemp path = gettemp path True False 0++mktemp path = do v <- gettemp path False False 0+ return $ case v of Just (path',_) -> Just path'; _ -> Nothing++mkdtemp path = do v <- gettemp path False True 0+ return $ case v of Just (path',_) -> Just path'; _ -> Nothing++------------------------------------------------------------------------++gettemp :: FilePath -> Bool -> Bool -> Int -> IO (Maybe (FilePath, Handle))++gettemp [] _ _ _ = return Nothing+gettemp _ True True _ = return Nothing++gettemp path doopen domkdir slen = do+ --+ -- firstly, break up the path and extract the template+ --+ let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path+ (p,t) = break (== 'X') r+ in (p,t,s)+ --+ -- an error if there is only a suffix, it seems+ --+ if null pref && null tmpl then return Nothing else do {+ --+ -- replace end of template with process id, and rest with randomness+ --+ ;pid <- liftM show $ getProcessID+ ;let (rest, xs) = merge tmpl pid+ ;as <- randomise rest+ ;let tmpl' = as ++ xs+ path' = pref ++ tmpl' ++ suff+ --+ -- just check if we can get at the directory we might need+ --+ ;dir_ok <- if doopen || domkdir+ then let d = reverse $ dropWhile (/= '/') $ reverse path'+ in doesDirectoryExist d+ else return True++ ;if not dir_ok then return Nothing else do {+ --+ -- We need a function for looking for appropriate temp files+ --+ ;let fn p+ | doopen = handleJust isInUse (\_ -> return Nothing) $+ do h <- open0600 p ; return $ Just h+ | domkdir = handleJust alreadyExists (\_ -> return Nothing) $+ do mkdir0700 p ; return $ Just undefined+ | otherwise = do b <- doesFileExist p+ return $ if b then Nothing else Just undefined++ --+ -- now, try to create the tmp file, permute if we can't+ -- once we've tried all permutations, give up+ --+ ;let tryIt p t i =+ do v <- fn p+ case v of Just h -> return $ Just (p,h) -- it worked+ Nothing -> let (i',t') = tweak i t+ in if null t'+ then return Nothing -- no more+ else tryIt (pref++t'++suff) t' i'+ ;tryIt path' tmpl' 0++ }}++--+-- Replace X's with pid digits. Complete rewrite+--+merge :: String -> String -> (String,String)+merge t [] = (t ,[])+merge [] _ = ([] ,[])+merge (_:ts) (p:ps) = (ts',p:ps')+ where (ts',ps') = merge ts ps++--+-- And replace remaining X's with random chars+-- randomR is pretty slow, oh well.+--+randomise :: String -> IO String+randomise [] = return []+randomise ('X':xs) = do p <- getRandom ()+ let c = chr $! if p < 26+ then p + (ord 'A')+ else (p - 26) + (ord 'a')+ xs' <- randomise xs+ return (c : xs')+randomise s = return s++--+-- "tricky little algorithm for backward compatibility"+-- could do with a Haskellish rewrite+--+tweak :: Int -> String -> (Int,String)+tweak i s+ | i > length s - 1 = (i,[]) -- no more+ | s !! i == 'Z' = if i == length s - 1+ then (i,[]) -- no more+ else let s' = splice (i+1) 'a'+ in tweak (i+1) s' -- loop+ | otherwise = let c = s !! i in case () of {_+ | isDigit c -> (i, splice i 'a' )+ | c == 'z' -> (i, splice i 'A' )+ | otherwise -> let c' = chr $ (ord c) + 1 in (i,splice i c')+ }+ where+ splice j c = let (a,b) = splitAt j s in a ++ [c] ++ tail b++-- ---------------------------------------------------------------------++alreadyExists :: Exception -> Maybe Exception+alreadyExists e@(IOException ioe)+ | isAlreadyExistsError ioe = Just e+ | otherwise = Nothing+alreadyExists _ = Nothing++isInUse :: Exception -> Maybe ()+#ifndef __MINGW32__+isInUse (IOException ioe)+ | isAlreadyExistsError ioe = Just ()+ | otherwise = Nothing+isInUse _ = Nothing+#else+isInUse (IOException ioe)+ | isAlreadyInUseError ioe = Just ()+ | isPermissionError ioe = Just ()+ | isAlreadyExistsError ioe = Just () -- we throw this+ | otherwise = Nothing+isInUse _ = Nothing+#endif++-- ---------------------------------------------------------------------+-- Create a file mode 0600 if possible+--+-- N.B. race condition between testing existence and opening+-- But we can live with that to avoid a posix dependency, right?+--+open0600 :: FilePath -> IO Handle+open0600 f = do+ b <- doesFileExist f+ if b then ioError err -- race+ else openFile f ReadWriteMode+ where+ err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing++{-+-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)+--+open0600 f = do+ openFd f ReadWrite (Just o600) excl >>= fdToHandle+ where+ o600 = ownerReadMode `unionFileModes` ownerWriteMode+ excl = defaultFileFlags { exclusive = True }+-}++--+-- create a directory mode 0700 if possible+--+mkdir0700 :: FilePath -> IO ()+mkdir0700 dir = createDirectory dir+{-+ System.Posix.Directory.createDirectory dir ownerModes+-}++-- | getProcessId, stolen from GHC+--+#ifdef __MINGW32__+foreign import ccall unsafe "_getpid" getProcessID :: IO Int+#else+getProcessID :: IO Int+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral+#endif++-- ---------------------------------------------------------------------+-- | Use a variety of random functions, if you like.+--+getRandom :: () -> IO Int++getRandom _ = getStdRandom (randomR (0,51))
+ Yi/Monad.hs view
@@ -0,0 +1,46 @@+module Yi.Monad where++import Data.IORef+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans+++-- | Combination of the Control.Monad.State 'modify' and 'gets'+getsAndModify :: MonadState s m => (s -> (s,a)) -> m a+getsAndModify f = do+ e <- get+ let (e',result) = f e+ put e'+ return result++readRef :: (MonadIO m) => IORef a -> m a+readRef r = liftIO $ readIORef r++writeRef :: (MonadIO m) => IORef a -> a -> m ()+writeRef r x = liftIO $ writeIORef r x++modifyRef :: (MonadIO m) => IORef a -> (a -> a) -> m ()+modifyRef r f = liftIO $ modifyIORef r f+++modifiesRef :: (MonadReader r m, MonadIO m) => (r -> IORef a) -> (a -> a) -> m ()+modifiesRef f g = do+ b <- asks f+ modifyRef b g++readsRef :: (MonadReader r m, MonadIO m) => (r -> IORef a) -> m a+readsRef f = do+ r <- asks f+ readRef r++writesRef :: (MonadReader r m, MonadIO m) => (r -> IORef a) -> a -> m ()+writesRef f x = do+ r <- asks f+ writeRef r x+++with :: (MonadReader yi m, MonadIO m) => (yi -> component) -> (component -> IO a) -> m a+with f g = do+ yi <- ask+ liftIO $ g (f yi)
+ Yi/Process.hs view
@@ -0,0 +1,59 @@+--+-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++--+-- | A Posix.popen compatibility mapping.+-- Based on PosixCompat, originally written by Derek Elkins for lambdabot+--+module Yi.Process (popen, runShellCommand) where++import System.IO+import System.Process+import System.Exit ( ExitCode )+import Control.Concurrent (forkIO)+import System.Environment ( getEnv )++import qualified Control.Exception++popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ExitCode)+popen file args minput =+ Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do++ (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing++ case minput of+ Just input -> hPutStr inp input >> hClose inp -- importante!+ Nothing -> return ()++ -- Now, grab the input+ output <- hGetContents out+ errput <- hGetContents err++ -- SimonM sez:+ -- ... avoids blocking the main thread, but ensures that all the+ -- data gets pulled as it becomes available. you have to force the+ -- output strings before waiting for the process to terminate.+ --+ forkIO (Control.Exception.evaluate (length output) >> return ())+ forkIO (Control.Exception.evaluate (length errput) >> return ())++ -- And now we wait. We must wait after we read, unsurprisingly.+ exitCode <- waitForProcess pid -- blocks without -threaded, you're warned.++ return (output,errput,exitCode)++------------------------------------------------------------------------+-- | Run a command using the system shell, returning stdout, stderr and exit code++shellFileName :: IO String+shellFileName = Prelude.catch (getEnv "SHELL") (\_ -> return "/bin/sh")++shellCommandSwitch :: String+shellCommandSwitch = "-c"++runShellCommand :: String -> IO (String,String,ExitCode)+runShellCommand cmd = do+ shell <- shellFileName+ popen shell [shellCommandSwitch, cmd] Nothing
+ Yi/Search.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++-- Copyright (c) Tuomo Valkonen 2004.+-- Copyright (c) 2005, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- Copyright (c) 2007 Jean-Philippe Bernardy++-- | Search/Replace functions++module Yi.Search (+ setRegexE, -- :: SearchExp -> EditorM ()+ getRegexE, -- :: EditorM (Maybe SearchExp)+ SearchMatch,+ SearchExp,+ SearchF(..),+ searchAndRepLocal, -- :: String -> String -> IO Bool+ doSearch, -- :: (Maybe String) -> [SearchF]+ -- -> Direction -> YiM ()+ searchInit, -- :: String+ -- -> [SearchF]+ -- -> IO SearchExp+ continueSearch, -- :: SearchExp+ -- -> Direction+ -- -> IO SearchResult++ -- * Incremental Search++ isearchInitE,+ isearchIsEmpty,+ isearchAddE,+ isearchPrevE,+ isearchNextE,+ isearchWordE,+ isearchDelE,+ isearchCancelE,+ isearchFinishE,++ -- * Replace+ qrNext,+ qrReplaceOne++ ) where++import Yi.Buffer+import Yi.Buffer.HighLevel+import Text.Regex.Posix.String ( Regex, compExtended, compIgnoreCase, compNewline, compile, execBlank )+import Yi.Editor+import qualified Yi.Editor as Editor++import Data.Bits ( (.|.) )+import Data.Char+import Data.Maybe+import Data.List+import Data.Typeable++import Control.Monad.State++import Yi.Core++-- ---------------------------------------------------------------------+-- Searching and substitutions with regular expressions+--+-- The most recent regex is held by the editor. You can get at it with+-- getRegeE. This is useful to determine if there was a previous+-- pattern.+--++-- | Put regex into regex 'register'+setRegexE :: SearchExp -> EditorM ()+setRegexE re = modify $ \e -> e { regex = Just re }++-- Return contents of regex register+getRegexE :: EditorM (Maybe SearchExp)+getRegexE = gets regex+++-- ---------------------------------------------------------------------+--+-- | Global searching. Search for regex and move point to that position.+-- @Nothing@ means reuse the last regular expression. @Just s@ means use+-- @s@ as the new regular expression. Direction of search can be+-- specified as either @Backward@ or @Forward@ (forwards in the buffer).+-- Arguments to modify the compiled regular expression can be supplied+-- as well.+--++--+-- What would be interesting would be to implement our own general+-- mechanism to allow users to supply a regex function of any kind, and+-- search with that. This removes the restriction on strings be valid+-- under regex(3).+--++data SearchF = Basic -- ^ Use non-modern (i.e. basic) regexes+ | IgnoreCase -- ^ Compile for matching that ignores char case+ | NoNewLine -- ^ Compile for newline-insensitive matching+ deriving Eq++type SearchMatch = (Int, Int)+type SearchResult = Maybe (Either SearchMatch SearchMatch)+type SearchExp = (String, Regex)++doSearch :: (Maybe String) -- ^ @Nothing@ means used previous+ -- pattern, if any. Complain otherwise.+ -- Use getRegexE to check for previous patterns+ -> [SearchF] -- ^ Flags to modify the compiled regex+ -> Direction -- ^ @Backward@ or @Forward@+ -> YiM ()++doSearch s fs d =+ case s of+ Just re -> searchInit re fs >>= (flip continueSearch) d >>= f+ Nothing -> do+ mre <- withEditor getRegexE+ case mre of+ Nothing -> errorEditor "No previous search pattern" -- NB+ Just r -> continueSearch r d >>= f+ where+ f mp = case mp of+ Just (Right _) -> return ()+ Just (Left _) -> msgEditor "Search wrapped"+ Nothing -> errorEditor "Pattern not found"+++continueSearch :: SearchExp+ -> Direction+ -> YiM SearchResult++continueSearch _ Backward = do+ errorEditor "Backward searching is unimplemented"+ return Nothing+continueSearch (s, re) _ = searchF s re++--+-- Set up a search.+--+searchInit :: String -> [SearchF] -> YiM SearchExp+searchInit re fs = do+ Right c_re <- lift $ compile (extended .|. igcase .|. newline) execBlank re+ let p = (re,c_re)+ withEditor $ setRegexE p+ return p++ where+ extended | Basic `elem` fs = 0+ | otherwise = compExtended -- extended regex dflt+ igcase | IgnoreCase `elem` fs = compIgnoreCase+ | otherwise = 0 -- case insensitive dflt+ newline | NoNewLine `elem` fs = 0+ | otherwise = compNewline -- newline is special+++-- ---------------------------------------------------------------------+-- Internal++--+-- Do a forward search, placing cursor at first char of pattern, if found.+-- Keymaps may implement their own regex language. How do we provide for this?+-- Also, what's happening with ^ not matching sol?+--+searchF :: String -> Regex -> YiM SearchResult+searchF _ c_re = withBuffer $ do+ mp <- do+ p <- pointB+ rightB -- start immed. after cursor+ mp <- regexB c_re+ case fmap Right mp of+ x@(Just _) -> return x+ _ -> do moveTo 0+ np <- regexB c_re+ moveTo p+ return (fmap Left np)+ case mp of+ Just (Right (p,_)) -> moveTo p+ Just (Left (p,_)) -> moveTo p+ _ -> return ()+ return mp++------------------------------------------------------------------------+-- Global search and replace+--+++------------------------------------------------------------------------+-- | Search and replace /on current line/. Returns Bool indicating+-- success or failure+--+-- TODO too complex.+--+searchAndRepLocal :: String -> String -> YiM Bool+searchAndRepLocal [] _ = return False -- hmm...+searchAndRepLocal re str = do+ Right c_re <- lift $ compile compExtended execBlank re+ withEditor $ setRegexE (re,c_re) -- store away for later use++ mp <- withBuffer $ do -- find the regex+ mp <- regexB c_re+ return mp+ case mp of+ Just (i,j) -> withBuffer $ do+ p <- pointB -- all buffer-level atm+ moveToEol+ ep <- pointB -- eol point of current line+ moveTo i+ moveToEol+ eq <- pointB -- eol of matched line+ moveTo p -- go home. sub doesn't move+ if (ep /= eq) -- then match isn't on current line+ then return False+ else do -- do the replacement+ moveTo i+ deleteN (j - i)+ insertN str+ moveTo p -- and back to where we were!+ return True -- signal success+ Nothing -> return False+++--------------------------+-- Incremental search+++newtype Isearch = Isearch [(String, Int, Direction)] deriving Typeable+-- Maybe this should not be saved in a Dynamic component!+-- it could be embedded in the Keymap state.++instance Initializable Isearch where+ initial = (Isearch [])++isearchInitE :: Direction -> EditorM ()+isearchInitE dir = do+ p <- withBuffer0 pointB+ setDynamic (Isearch [("",p,dir)])+ printMsg "I-search: "++isearchIsEmpty :: EditorM Bool+isearchIsEmpty = do+ Isearch s <- getDynamic+ return $ not $ null $ fst3 $ head $ s+ where fst3 (x,_,_) = x++isearchAddE :: String -> EditorM ()+isearchAddE increment = do+ Isearch s <- getDynamic+ let (previous,p0,direction) = head s+ let current = previous ++ increment+ printMsg $ "I-search: " ++ current+ prevPoint <- withBuffer0 pointB+ withBuffer0 $ moveTo p0+ mp <- withBuffer0 $ searchB direction current+ case mp of+ Nothing -> do withBuffer0 $ moveTo prevPoint -- go back to where we were+ setDynamic $ Isearch ((current,p0,direction):s)+ printMsg $ "Failing I-search: " ++ current+ Just p -> do setDynamic $ Isearch ((current,p,direction):s)+ withBuffer0 $ moveTo (p+length current)++isearchDelE :: EditorM ()+isearchDelE = do+ Isearch s <- getDynamic+ case s of+ (_:(text,p,dir):rest) -> do+ withBuffer0 $ moveTo (p+length text)+ setDynamic $ Isearch ((text,p,dir):rest)+ printMsg $ "I-search: " ++ text+ _ -> return () -- if the searched string is empty, don't try to remove chars from it.++-- TODO: merge isearchPrevE and isearchNextE+isearchPrevE :: EditorM ()+isearchPrevE = do+ Isearch ((current,p0,_dir):rest) <- getDynamic+ withBuffer0 $ moveTo (p0 - 1)+ mp <- withBuffer0 $ searchB Backward current+ case mp of+ Nothing -> return ()+ Just p -> do setDynamic $ Isearch ((current,p,Backward):rest)+ withBuffer0 $ moveTo (p+length current)++isearchNextE :: EditorM ()+isearchNextE = do+ Isearch ((current,p0,_dir):rest) <- getDynamic+ withBuffer0 $ moveTo (p0 + 1)+ mp <- withBuffer0 $ searchB Forward current+ case mp of+ Nothing -> return ()+ Just p -> do setDynamic $ Isearch ((current,p,Forward):rest)+ withBuffer0 $ moveTo (p+length current)++isearchWordE :: EditorM ()+isearchWordE = do+ text <- withBuffer0 (pointB >>= nelemsB 32) -- add maximum 32 chars at a time.+ let (prefix, rest) = span (not . isAlpha) text+ word = takeWhile isAlpha rest+ isearchAddE (prefix ++ word)++isearchFinishE :: EditorM ()+isearchFinishE = do+ Isearch s <- getDynamic+ let (_,p0,_) = last s+ withBuffer0 $ setSelectionMarkPointB p0+ printMsg "mark saved where search started"++isearchCancelE :: EditorM ()+isearchCancelE = do+ Isearch s <- getDynamic+ let (_,p0,_) = last s+ withBuffer0 $ moveTo p0+ printMsg "Quit"+++-----------------+-- Query-Replace++qrNext :: BufferRef -> String -> YiM ()+qrNext b what = do+ mp <- withGivenBuffer b $ searchB Forward what+ case mp of+ Nothing -> do+ withEditor $ printMsg "String to search not found"+ closeWindow+ Just p -> withGivenBuffer b $ do+ moveTo p+ m <- getSelectionMarkB+ setMarkPointB m (p+length what)+++qrReplaceOne :: BufferRef -> String -> String -> YiM ()+qrReplaceOne b what replacement = do+ withGivenBuffer b $ do+ deleteN (length what)+ insertN replacement+ qrNext b what
+ Yi/String.hs view
@@ -0,0 +1,77 @@+--+-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++-- | String manipulation utilities+--++module Yi.String (chomp,+ split,+ capitalize,+ capitalizeFirst,+ dropSpace -- :: String -> String+) where++import Data.List (isSuffixOf,isPrefixOf)+import Data.Char (toUpper, toLower, isSpace, isAlphaNum)++capitalize :: String -> String+capitalize [] = []+capitalize (c:cs) = toUpper c : map toLower cs++capitalizeFirst :: String -> String+capitalizeFirst [] = []+capitalizeFirst (c:cs) + | isAlphaNum c = toUpper c : map toLower cs+ | otherwise = c : capitalizeFirst cs+++-- | Remove any trailing strings matching /irs/ (input record separator)+-- from input string. Like perl's chomp(1).+--+chomp :: String -> String -> String+chomp irs st+ | irs `isSuffixOf` st+ = let st' = reverse $ drop (length irs) (reverse st) in chomp irs st'+ | otherwise = st+{-# INLINE chomp #-}++--+-- | Split a list into pieces that were held together by glue. Example:+--+-- > split ", " "one, two, three" ===> ["one","two","three"]+--+split :: Eq a => [a] -- ^ Glue that holds pieces together+ -> [a] -- ^ List to break into pieces+ -> [[a]] -- ^ Result: list of pieces++split glue xs = split' xs+ where+ split' [] = []+ split' xs' = piece : split' (dropGlue rest)+ where (piece, rest) = breakOnGlue glue xs'+ dropGlue = drop (length glue)+{-# INLINE split #-}++--+-- | Break off the first piece of a list held together by glue,+-- leaving the glue attached to the remainder of the list. Example:+-- Like break, but works with a [a] match.+--+-- > breakOnGlue ", " "one, two, three" ===> ("one", ", two, three")+--+breakOnGlue :: (Eq a) => [a] -- ^ Glue that holds pieces together+ -> [a] -- ^ List from which to break off a piece+ -> ([a],[a]) -- ^ Result: (first piece, glue ++ rest of list)+breakOnGlue _ [] = ([],[])+breakOnGlue glue rest@(x:xs)+ | glue `isPrefixOf` rest = ([], rest)+ | otherwise = (x:piece, rest')+ where (piece, rest') = breakOnGlue glue xs+{-# INLINE breakOnGlue #-}+++-- | Trim spaces at beginning /and/ end+dropSpace :: [Char] -> [Char]+dropSpace = let f = reverse . dropWhile isSpace in f . f
+ Yi/Style.hs view
@@ -0,0 +1,149 @@+--+-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++--+-- | Colors and friends.+--++module Yi.Style where++import Data.Word (Word8)+import Data.Char (chr, ord)++--+-- | The UI type+--+data UIStyle =+ UIStyle {+ window :: !Style -- ^ window fg and bg (ignore for now)+ , modeline :: !Style -- ^ out of focus modeline colours+ , modeline_focused :: !Style -- ^ in focus modeline+ , selected :: !Style -- ^ the selected portion+ , eof :: !Style -- ^ empty file marker colours+ } + deriving (Eq, Show, Ord)++data Color+ = RGB {-# UNPACK #-} !Word8 !Word8 !Word8+ | Default+ | Reverse+ deriving (Eq,Ord,Show)++-- | Convert a color to its text specification, as to be accepted by XParseColor++showHex1 :: Word8 -> Char+showHex1 x | x < 10 = chr (ord '0' + fromIntegral x)+ | otherwise = chr (ord 'A' + fromIntegral x - 10)++showsHex :: Word8 -> (String -> String)+showsHex x s =+ showHex1 (x `div` 16) : showHex1 (x `mod` 16) : s++colorToText :: Color -> String+colorToText Default = "black"+colorToText Reverse = "white"+colorToText (RGB r g b) = ('#':) . showsHex r . showsHex g . showsHex b $ []+++--+-- | Default settings+--+{-+ Notice that the selected field is initially set to the default, which+ essentially means that selected text will not be highlighted. The reason+ for this is that if the mode does not remember to UnSet the mark after,+ for example, cutting, then there will always be a highlighted region, that+ is essentially the default for now which has worked up until now because the+ selected text wasn't highlighted, now that it is, we need the modes to unset+ the mark when nothing should be hightlighted.+-}+uiStyle :: UIStyle+uiStyle = UIStyle {+ window = Style defaultfg defaultbg+ ,modeline = Style black darkcyan+ ,modeline_focused = Style brightwhite darkcyan+ ,selected = Style reversefg reversebg+ ,eof = Style blue defaultbg+ }++defaultStyle :: Style+defaultStyle = Style defaultfg defaultbg++commentStyle :: Style+commentStyle = lineCommentStyle++lineCommentStyle :: Style+lineCommentStyle = purpleA++keywordStyle :: Style+keywordStyle = darkblueA++operatorStyle :: Style+operatorStyle = brownA++upperIdStyle :: Style+upperIdStyle = darkgreenA++stringStyle :: Style+stringStyle = darkcyanA++numberStyle :: Style+numberStyle = darkredA+++blackA , greyA, darkredA, redA, darkgreenA, greenA, brownA :: Style+yellowA, darkblueA, blueA, purpleA, magentaA, darkcyanA :: Style+cyanA, whiteA, brightwhiteA :: Style+blackA = Style black defaultbg+greyA = Style grey defaultbg+darkredA = Style darkred defaultbg+redA = Style red defaultbg+darkgreenA = Style darkgreen defaultbg+greenA = Style green defaultbg+brownA = Style brown defaultbg+yellowA = Style yellow defaultbg+darkblueA = Style darkblue defaultbg+blueA = Style blue defaultbg+purpleA = Style purple defaultbg+magentaA = Style magenta defaultbg+darkcyanA = Style darkcyan defaultbg+cyanA = Style cyan defaultbg+whiteA = Style white defaultbg+brightwhiteA = Style brightwhite defaultbg++------------------------------------------------------------------------++-- | Foreground and background color pairs+data Style = Style {-# UNPACK #-} !Color !Color deriving (Eq,Ord,Show)++------------------------------------------------------------------------++-- | Some simple colours (derivied from proxima/src/common/CommonTypes.hs)++black, grey, darkred, red, darkgreen, green, brown, yellow :: Color+darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color+black = RGB 0 0 0+grey = RGB 128 128 128+darkred = RGB 139 0 0+red = RGB 255 0 0+darkgreen = RGB 0 100 0+green = RGB 0 128 0+brown = RGB 165 42 42+yellow = RGB 255 255 0+darkblue = RGB 0 0 139+blue = RGB 0 0 255+purple = RGB 128 0 128+magenta = RGB 255 0 255+darkcyan = RGB 0 139 139 +cyan = RGB 0 255 255+white = RGB 165 165 165+brightwhite = RGB 255 255 255++defaultfg, defaultbg, reversefg, reversebg :: Color+defaultfg = Default+defaultbg = Default+reversefg = Reverse+reversebg = Reverse+
+ Yi/Syntax.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}+--+-- Copyright (C) 2007 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++-- | This module defines a common interface for syntax highlighters.+--+-- Yi syntax highlighters are expressed as explicit lazy computations+-- of type 'Highlighter a' below; this type is effectively isomorphic+-- to [Char] -> [Style], but are explicitly lazy to admit safe fast uses.+--++module Yi.Syntax + ( Highlighter ( .. )+ , ExtHL ( .. )+ ) +where++import Yi.Style+import qualified Data.ByteString.Lazy.Char8 as LB+++ ++-- | The main type of syntax highlighters. This record type combines all+-- the required functions, and is parametrized on the type of the internal+-- state.+--+-- Highlighters currently directly use the Vty color types; among other+-- things, this prevents the gtk port from using synhl.+data Highlighter a = + SynHL { hlStartState :: a -- ^ The start state for the highlighter.+ -- | Colorize a block of data passed in as a ByteString,+ -- returning the new state and any attributes produced.+ -- This *must* be implementable as a `B.foldl'.+ , hlColorize :: LB.ByteString -> a -> (a, [ (Int,Style)] )+ -- | Colorize the end of file; this exists only to inform+ -- states that lookahead will never happen.+ , hlColorizeEOF :: a -> [ (Int,Style) ]+ }++data ExtHL = forall a. Eq a => ExtHL (Maybe (Highlighter a))
+ Yi/Syntax/Cabal.x view
@@ -0,0 +1,180 @@+-- -*- haskell -*- +--+-- Lexical syntax for illiterate Haskell 98.+--+-- (c) Simon Marlow 2003, with the caveat that much of this is+-- translated directly from the syntax in the Haskell 98 report.+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.Cabal+ ( highlighter ) +where++import qualified Data.ByteString.Char8+import qualified Yi.FingerString+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Yi.Syntax+import Yi.Style+ ( Style ( .. )+ , defaultStyle+ , commentStyle+ , lineCommentStyle+ , keywordStyle+ , operatorStyle+ , upperIdStyle+ , stringStyle+ , numberStyle+ )+}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@reservedid = + GPL+ |LGPL+ |BSD3+ |BSD4+ |PublicDomain+ |AllRightsReserved+ |OtherLicense+ |if+ |flag++@fieldid =+ [Nn]ame+ |[Vv]ersion+ |[Cc]abal\-Version+ |[Cc]abal\-version+ |[Dd]escription+ |[Ll]icense+ |[Ll]icense\-file+ |[Aa]uthor+ |[Mm]aintainer+ |[Bb]uild\-Depends+ |[Bb]uild\-depends+ |[Ee]xecutable+ |[Mm]ain\-Is+ |[Mm]ain\-is+ |[Oo]ther\-Modules+ |[Oo]ther\-modules+ |[Gg]hc\-Options+ |[Gg]hc\-options+ |[Cc]opyright+ |[Hh]omepage+ |[Ss]ynopsis+ |[Ee]xposed\-Modules+ |[Ee]xposed\-modules+ |[Ii]nclude\-Dirs+ |[Ii]nclude\-dirs+ |[Cc]\-Sources+ |[Cc]\-sources+ |[Ee]xtra\-Libraries+ |[Ee]xtra\-libraries+ |[Ee]xtensions+ |[Cc]ategory+ |[Bb]uildabl+ |[Ee]xtra\-[Ss]ource\-[Ff]iles++@reservedop =+ ">" | ">=" | "<" | "<="++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace+++-- I'm allowing full haskell style comments here, I think that maybe+-- in the future cabal will allow this too so ... Also I don't think it+-- does significant harm at the moment+<nestcomm> {+ "{-" { m (subtract 1) commentStyle }+ "-}" { m (+1) commentStyle }+ $white+ { c defaultStyle } -- whitespace+ . { c commentStyle }+}++<0> {+ "--"\-* $symbol $symchar* { c defaultStyle }+ "--"\-*[^\n]* { c commentStyle }++ "{-" { m (subtract 1) commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }+ @varid { c defaultStyle }+ @conid { c defaultStyle }++ @fieldid ":" { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c defaultStyle }++ @decimal + | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}++{+++type HlState = Int++stateToInit x | x < 0 = nestcomm+ | otherwise = 0++initState = 0++#include "alex.hsinc"+}
+ Yi/Syntax/Cplusplus.x view
@@ -0,0 +1,225 @@+-- -*- haskell -*- +--+-- Simple syntax highlighting for c/c++ files+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.Cplusplus ( highlighter ) where+{- Standard Library Modules Imported -}+import qualified Data.ByteString.Char8+import qualified Yi.FingerString+import qualified Data.ByteString.Lazy.Char8 as LB+{- External Library Modules Imported -}+{- Local Modules Imported -}+import qualified Yi.Syntax+import Yi.Style+ ( Style ( .. )+ , defaultStyle+ , commentStyle+ , lineCommentStyle+ , keywordStyle+ , operatorStyle+ , upperIdStyle+ , stringStyle+ , numberStyle+ )+{- End of Module Imports -}++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@reservedid = + asm+ |break+ |case+ |continue+ |default+ |do+ |else+ |enum+ |for+ |fortran+ |goto+ |if+ |return+ |sizeof+ |struct+ |switch+ |typedef+ |union+ |while+ |_Bool+ |_Complex+ |_Imaginary+ |bool+ |char+ |double+ |float+ |int+ |long+ |short+ |signed+ |size_t+ |unsigned+ |void+ |auto+ |const+ |extern+ |inline+ |register+ |restrict+ |static+ |volatile+ |NULL+ |MAX+ |MIN+ |TRUE+ |FALSE+ |__LINE__+ |__DATA__+ |__FILE__+ |__func__+ |__TIME__+ |__STDC__+ |and+ |and_eq+ |bitand+ |bitor+ |catch+ |compl+ |const_cast+ |delete+ |dynamic_cast+ |false+ |for+ |friend+ |new+ |not+ |not_eq+ |operator+ |or+ |or_eq+ |private+ |protected+ |public+ |reinterpret_cast+ |static_cast+ |this+ |throw+ |true+ |try+ |typeid+ |using+ |xor+ |xor_eq+ |class+ |namespace+ |typename+ |template+ |virtual+ |bool+ |explicit+ |export+ |inline+ |mutable+ |wchar_t+++@reservedop = + "->" | "*" | "+" | "-" | "%" | \\ | "||" | "&&" | "?" | ":"++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace++<nestcomm> {+ -- We could do nested comments like this+ -- "/*" { m (subtract 1) commentStyle }+ "*/" { m (+1) commentStyle }+ $white+ { c defaultStyle } -- whitespace+ . { c commentStyle }+}++<0> {+ "//"[^\n]* { c commentStyle }++ "/*" { m (subtract 1) commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }+ @varid { c defaultStyle }+ @conid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c upperIdStyle }++ @decimal + | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}+++{++type HlState = Int+++stateToInit x | x < 0 = nestcomm+ | otherwise = 0++initState = 0++#include "alex.hsinc"+}
+ Yi/Syntax/Haskell.x view
@@ -0,0 +1,123 @@+-- -*- haskell -*- +--+-- Lexical syntax for illiterate Haskell 98.+--+-- (c) Simon Marlow 2003, with the caveat that much of this is+-- translated directly from the syntax in the Haskell 98 report.+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.Haskell ( highlighter ) where++import qualified Data.ByteString.Char8+import qualified Yi.FingerString+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Yi.Syntax+import Yi.Style++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@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|+ safe|threadsafe|unsafe|stdcall|ccall|dotnet++@reservedop =+ ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>"++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace++<nestcomm> {+ "{-" { m (subtract 1) commentStyle }+ "-}" { m (+1) commentStyle }+ $white+ { c defaultStyle } -- whitespace+ . { c commentStyle }+}++<0> {+ "--"\-* $symbol $symchar* { c defaultStyle }+ "--"\-*[^\n]* { c commentStyle }++ "{-" { m (subtract 1) commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }+ @varid { c defaultStyle }+ @conid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c upperIdStyle }++ @decimal + | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}++{+++type HlState = Int++stateToInit x | x < 0 = nestcomm+ | otherwise = 0++initState = 0++#include "alex.hsinc"+}
+ Yi/Syntax/Latex.x view
@@ -0,0 +1,111 @@+-- -*- haskell -*- +--+-- Simple syntax highlighting for Latex source files+--+-- This is not intended to be a lexical analyser for+-- latex, merely good enough to provide some syntax+-- highlighting for latex source files.+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.Latex ( highlighter ) where++import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Yi.FingerString+import qualified Yi.Syntax+import Yi.Style++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@reservedid = \\newcommand|\\begin|\\end++@reservedop =+ ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>"++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace+++<0> {+ "%"\-*[^\n]* { c commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }++ \\ @varid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c upperIdStyle }++ @decimal + | 0[oO] @octal+ | 0[xX] @hexadecimal { c operatorStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ . { c defaultStyle }+}++{+++type HlState = Int++{- See Haskell.x which uses this to say whether we are in a+ comment (perhaps a nested comment) or not.+-}+stateToInit x = 0++initState = 0++#include "alex.hsinc"+}
+ Yi/Syntax/LiterateHaskell.x view
@@ -0,0 +1,176 @@+-- -*- haskell -*-+--+-- Lexical syntax for literate Haskell 98.+--+-- (c) Simon Marlow 2003, with the caveat that much of this is+-- translated directly from the syntax in the Haskell 98 report.+--+-- Adapted to literate Haskell 98 by Nicolas Pouillard+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.LiterateHaskell ( highlighter ) where++import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Yi.FingerString+import qualified Yi.Syntax+import Yi.Style++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@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|+ safe|threadsafe|unsafe|stdcall|ccall|dotnet++@reservedop =+ ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>"++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace++<nestcomm> {+ "{-" { m Comment commentStyle }+ "-}" { m unComment commentStyle }+ $white+ { c defaultStyle } -- whitespace+ . { c commentStyle }+}++<0> {+ "\begin{code}" { m (const CodeBlock) keywordStyle }+ ">" { m (const CodeLine) operatorStyle }+ $white+ { c defaultStyle } -- whitespace+ . { c latexStyle }+}++<codeBlock> {+ "\end{code}" { m (const LaTeX) keywordStyle }++ $white+ { c defaultStyle } -- whitespace++ "--"\-* $symbol $symchar* { c defaultStyle }+ "--"\-*[^\n]* { c commentStyle }++ "{-" { m Comment commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }+ @varid { c defaultStyle }+ @conid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c upperIdStyle }++ @decimal+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}++<codeLine> {+ [\t\n\r\f\v]+ { m (const LaTeX) keywordStyle }++ [\ \t]+ { c defaultStyle } -- whitespace++ "--"\-* $symbol $symchar* { c defaultStyle }+ "--"\-*[^\n]* { c commentStyle }++ "{-" { m Comment commentStyle }++ $special { c defaultStyle }++ @reservedid { c keywordStyle }+ @varid { c defaultStyle }+ @conid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c upperIdStyle }++ @decimal+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}++{++data HlState = CodeBlock+ | CodeLine+ | Comment { unComment :: HlState }+ | LaTeX+ deriving (Eq)++stateToInit (Comment _) = nestcomm+stateToInit CodeBlock = codeBlock+stateToInit CodeLine = codeLine+stateToInit LaTeX = 0++initState = LaTeX++latexStyle = commentStyle++#include "alex.hsinc"++}
+ Yi/Syntax/Srmc.x view
@@ -0,0 +1,127 @@+-- -*- haskell -*- +--+-- Simple syntax highlighting for srmc source.+-- Also to be used for pepa source files since pepa+-- is a subset of srmc.+-- I also believe that this makes a reasonable example+-- for new syntax files+--++{+{-# OPTIONS -w #-}+module Yi.Syntax.Srmc ( highlighter ) where+{- Standard Library Modules Imported -}+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Yi.FingerString+{- External Library Modules Imported -}+{- Local Modules Imported -}+import qualified Yi.Syntax+import Yi.Style+ ( Style ( .. )+ , defaultStyle+ , commentStyle+ , lineCommentStyle+ , keywordStyle+ , operatorStyle+ , upperIdStyle+ , stringStyle+ , numberStyle+ )+{- End of Module Imports -}++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$pepasymbol = [\;\.\,\+=\<\>]+$symbol = [$pepasymbol]++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol]+$nl = [\n\r]++@reservedid = Stop|infty++@reservedop = "&&" | "||"++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@double = $digit+ \. $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++haskell :-++<0> $white+ { c defaultStyle } -- whitespace+++<0> {+ "%"\-*[^\n]* { c commentStyle }+ "//"\-*[^\n]* { c commentStyle }++ -- $special { c defaultStyle }++ @reservedid { c keywordStyle }++ @varid { c stringStyle }+ @conid { c upperIdStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }++ @decimal + | @double+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c numberStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ . { c defaultStyle }+}++{++type HlState = Int++{- + See Haskell.x which uses this to say whether we are in a+ comment (perhaps a nested comment) or not.+-}+stateToInit x = 0++initState = 0++#include "alex.hsinc"+}
+ Yi/Syntax/Table.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS -#include "YiUtils.h" #-}++-- Copyright (C) 2007, 2008 Stefan O'Rear++-- | This module defines the list of syntax highlighter modules.++module Yi.Syntax.Table+ ( highlighters )+where++{- Standard Library Modules Imported -}+import qualified Data.Map as M+{- External Library Modules Imported -}+{- Local Modules Imported -}+import Yi.Syntax+ ( Highlighter, ExtHL(..) )+import qualified Yi.Syntax.Haskell+import qualified Yi.Syntax.LiterateHaskell (highlighter)+import qualified Yi.Syntax.Latex+import qualified Yi.Syntax.Srmc+import qualified Yi.Syntax.Cabal+import qualified Yi.Syntax.Cplusplus+{- End of Imports -}++highlighters :: M.Map String ExtHL+highlighters = M.fromList highList+++highList :: [ (String, ExtHL) ]+highList =+ [ ( "haskell" , ExtHL (Just Yi.Syntax.Haskell.highlighter) )+ , ("lithaskell", ExtHL (Just Yi.Syntax.LiterateHaskell.highlighter) )+ , ( "latex" , ExtHL (Just Yi.Syntax.Latex.highlighter) )+ , ( "cabal" , ExtHL (Just Yi.Syntax.Cabal.highlighter) )+ , ( "cplusplus", ExtHL (Just Yi.Syntax.Cplusplus.highlighter) )+ , ( "srmc" , ExtHL (Just Yi.Syntax.Srmc.highlighter) )+ , ( "none" , ExtHL (Nothing :: Maybe (Highlighter ())) )+ ]
+ Yi/Syntax/alex.hsinc view
@@ -0,0 +1,123 @@+-- -*- Haskell -*-++-- | The include file for alex-generated syntax highlighters. Because alex+-- declares its own types, any wrapper must have the highlighter in scope...+-- so it must be included. Doubleplusyuck.+--+-- You will need to import qualified Yi.Vty, and Yi.Syntax.+--+-- You will need to define initState and stateToInit and type HlState+--+-- Your actions must have type String -> $state -> ($state, [Attr])++type AlexInput = LB.ByteString+type Action a = AlexInput -> a -> (a, AlexResult)+type AlexState = (AlexInput, HlState)+type AlexResult = [ (Int, Style) ]++alexGetChar :: AlexInput -> Maybe (Char, AlexInput)+alexGetChar bs | LB.null bs = Nothing+ | otherwise = Just ( LB.head bs+ , LB.tail bs+ )++alexInputPrevChar = undefined++c :: Style -> Action a+c color str state = (state, [(fromIntegral $ LB.length str, color)])++m :: (s -> s) -> Style -> Action s+m mod color str state = (mod state, [(fromIntegral $ LB.length str, color)])++highlighter :: Yi.Syntax.Highlighter AlexState+highlighter = + Yi.Syntax.SynHL { Yi.Syntax.hlStartState = startState+ , Yi.Syntax.hlColorize = fun+ , Yi.Syntax.hlColorizeEOF = funEOF+ }+ where+ startState = ( LB.empty, initState )+ fun :: AlexInput -> AlexState -> (AlexState, AlexResult)+ fun bs (scrap, st) = + iter' hl_alex_scan_tkn full st+ where+ full = LB.append scrap bs+++ funEOF :: AlexState -> AlexResult+ funEOF (scrap, st) = + snd $ iter' alex_scan_tkn scrap st++ iter' :: ScanFun -> AlexInput -> HlState -> (AlexState, AlexResult)+ iter' scanFun bs s =+ case lastAction of+ (AlexNone, _) -> ((bs, s), [])+ (AlexLastSkip _ _, _) -> error "no skipping!"+ (AlexLastAcc k input len, _) -> + ( (str', finst), attrs ++ fattr )+ where+ (nst, attrs) = k (LB.take (fromIntegral len) bs) s+ ((str', finst), fattr) = iter' scanFun input nst+ where + lastAction = scanFun undefined bs 0# bs start AlexNone+ start = iUnbox (stateToInit s)++type ScanFun = Bool + -> AlexInput + -> (Int#)+ -> AlexInput + -> (Int#)+ -> AlexLastAcc KFun+ -> ( AlexLastAcc KFun, AlexInput )++type KFun = AlexInput -> HlState -> ( HlState, AlexResult)+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++-- Since the documented interface is insufficiently expressive, we have to use+-- the undocumented one :(++-- Our interface parses a token, but only if it is certain that the token is+-- the longest given available data.++hl_alex_scan_tkn :: ScanFun+hl_alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ case s of+ -1# -> (last_acc, input)+ _ -> hl_alex_scan_tkn' user orig_input len input s last_acc++hl_alex_scan_tkn' :: ScanFun+hl_alex_scan_tkn' user orig_input len input s last_acc =+ new_acc `seq`+ case alexGetChar input of+ Nothing -> (AlexNone, input) -- fail on EOF - important!+ Just (c, new_input) ->+ hl_alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc+ where+ base = alexIndexInt32OffAddr alex_base s+ (I# (ord_c)) = ord c+ offset = (base +# ord_c)+ check = alexIndexInt16OffAddr alex_check offset+ + new_s+ | (offset >=# 0#) && (check ==# ord_c) =+ alexIndexInt16OffAddr alex_table offset+ | otherwise =+ alexIndexInt16OffAddr alex_deflt s+ +++ where+ new_acc = check_accs (alex_accept `quickIndex` (I# (s)))++ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a pred : rest)+ | pred user orig_input (I# (len)) input = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred pred : rest)+ | pred user orig_input (I# (len)) input = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest
+ Yi/Templates.hs view
@@ -0,0 +1,131 @@+--+--+--++-- | Templates for inserting into documents+--++module Yi.Templates+ ( templates+ , templateNames+ , lookupTemplate+ , addTemplate+ )+where++{- Standard Library Modules Imported -}+import qualified Data.Map as Map+{- External Library Modules Imported -}+{- Local Modules Imported -}+import Yi.Buffer+ ( BufferM+ , insertN+ )+import Yi.Editor+ ( EditorM+ , withBuffer0+ , printMsg+ )+{- End of Module Imports -}++type Template = String+type TemplateName = String+type TemplateLookup = Map.Map TemplateName Template++templates :: TemplateLookup+templates =+ Map.fromList $ concat [ haskellTemplates ]++templateNames :: [ TemplateName ]+templateNames = Map.keys templates+++lookupTemplate :: TemplateName -> Maybe Template+lookupTemplate name = Map.lookup name templates+++haskellTemplates :: [ (TemplateName, Template) ]+haskellTemplates =+ [ ( "haskell-module"+ , unlines [ "module "+ , " ()"+ , "where"+ , ""+ , "{- Standard Library Modules Imported -}"+ , "{- External Library Modules Imported -}"+ , "{- Local Modules Imported -}"+ , "{- End of Module Imports -}"+ ]+ )+ , ( "cabal-file"+ , unlines [ "Name:"+ , "Version:"+ , "License:"+ , "Author:"+ , "Homepage:"+ , "Build-depends: base"+ , "Synopsis:"+ , ""+ , ""+ , "Executable:"+ , "Main-is:"+ , "Other-modules:"+ , "Include-dirs:"+ , "C-sources:"+ , "Extra-libraries:"+ , "Extensions:"+ , "Ghc-options: -Wall"+ , ""+ ]+ )+ , ( "GPL-2"+ , unlines + [ "--"+ , "-- 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 program is distributed in the hope that it will be useful,"+ , "-- but WITHOUT ANY WARRANTY; without even the implied warranty of"+ , "-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU"+ , "-- General Public License for more details."+ , "--"+ , "-- You should have received a copy of the GNU General Public License"+ , "-- along with this program; if not, write to the Free Software"+ , "-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA"+ , "-- 02111-1307, USA."+ , "--"+ ]+ )+ , ( "cabal-setup"+ , unlines+ [ "import Distribution.Simple"+ , "import System.Cmd"+ , " ( system )"+ , "import System.Exit"+ , " ( exitWith )"+ , "import System"+ , " ( getArgs )"+ , ""+ , "myHooks :: UserHooks"+ , "myHooks = defaultUserHooks"+ , ""+ , "main :: IO ()"+ , "main = do args <- getArgs"+ , " processArgs args"+ , ""+ , "processArgs :: [ String ] -> IO ()"+ , "processArgs _ = defaultMainWithHooks myHooks"+ ]+ )+ ]++addTemplate :: String -> EditorM ()+addTemplate tName =+ case lookupTemplate tName of+ Nothing -> printMsg "template-name not found"+ Just t -> withBuffer0 $ addTemplateBuffer t+ where+ addTemplateBuffer :: Template -> BufferM ()+ addTemplateBuffer t = insertN t
+ Yi/TextCompletion.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++-- Copyright (C) 2008 JP Bernardy++module Yi.TextCompletion (+ -- * Word completion+ wordCompleteB,+ resetCompleteB,+ completeWordB,+) where++import Yi.Completion+import Yi.Buffer+import Text.Regex+import Data.Char+import Data.Typeable+import Data.List+import qualified Data.Map as M++import Control.Applicative+import Control.Exception ( assert )+import Yi.Buffer.Normal+import Yi.Buffer.Region+import Yi.Editor+import Yi.Core++-- ---------------------------------------------------------------------+-- | Word completion+--+-- when doing keyword completion, we need to keep track of the word+-- we're trying to complete.++-- remember the word, if any, we're trying to complete, previous matches+-- we've seen, and the point in the search we are up to.+newtype Completion = Completion (Maybe (String,M.Map String (),Int)) deriving Typeable++instance Initializable Completion where+ initial = Completion Nothing+--+-- | Switch out of completion mode.+--+resetCompleteB :: BufferM ()+resetCompleteB = setDynamicB (Completion Nothing)++--+-- The word-completion BufferM (), down the buffer+--+wordCompleteB :: BufferM ()+wordCompleteB = getDynamicB >>= loop >>= setDynamicB++ where+ --+ -- work out where to start our next search+ --+ loop :: Completion -> BufferM Completion+ loop (Completion (Just (w,fm,n))) = do+ p <- pointB+ moveTo (n+1) -- start where we left off+ doloop p (w,fm)+ loop (Completion Nothing) = do+ p <- pointB+ w <- readRegionB =<< regionOfPartB Word Backward+ rightB -- start past point+ doloop p (w,M.singleton w ())++ --+ -- actually do the search, and analyse the result+ --+ doloop :: Int -> (String,M.Map String ())+ -> BufferM Completion++ doloop p (w,fm) = do+ m' <- nextWordMatch w+ moveTo p+ j <-regionStart <$> regionOfB Word+ case m' of+ Just (s,i)+ | j == i -- seen entire file+ -> do replaceLeftWith w+ return (Completion Nothing)++ | s `M.member` fm -- already seen+ -> loop (Completion (Just (w,fm,i)))++ | otherwise -- new+ -> do replaceLeftWith s+ return (Completion (Just (w,M.insert s () fm,i)))++ Nothing -> loop (Completion (Just (w,fm,(-1)))) -- goto start of file++ --+ -- replace word under cursor with @s@+ --+ replaceLeftWith :: String -> BufferM ()+ replaceLeftWith s = do+ r <- regionOfPartB Word Backward -- back at start+ replaceRegionB r s+ moveTo (regionStart r + length s)++ --+ -- Return next match, and index of that match (to be used for later searches)+ -- Leaves the cursor at the next word.+ --+ nextWordMatch :: String -> BufferM (Maybe (String,Int))+ nextWordMatch w = do+ let re = ("( |\t|\n|\r|^)"++w)+ let re_c = mkRegex re+ mi <- regexB re_c+ case mi of+ Nothing -> return Nothing+ Just (i,j) -> do+ c <- readAtB i+ let i' = if i == 0 && isAlphaNum c then 0 else i+1 -- for the space+ moveTo i'+ s <- readUnitB Word+ assert (s /= [] && i /= j) $ return $ Just (s,i')+++----------------------------+-- Alternative Word Completion++{-+ 'completeWordB' is an alternative to 'wordCompleteB'.+ Currently the main reason for this extra function is that the+ aforementioned is rather buggy, two problems I currently have with+ it is that it occasionally remembers the previous word it was completing+ before and completes that rather than the current one. More seriously+ it occasionally crashes yi by going into an infinite loop.++ In the longer term assuming that 'Yi.CharMove.wordCompleteB' is fixed+ (which I would love) then 'completeWordB' offers a slightly different+ interface. The user completes the word using the mini-buffer in the+ same way a user completes a buffer or file name when switching buffers+ or opening a file. This means that it never guesses and completes+ only as much as it can without guessing.++ I think there is room for both approaches. The 'wordCompleteB' approach+ which just guesses the completion from a list of possible completion+ and then re-hitting the key-binding will cause it to guess again.+ I think this is very nice for things such as completing a word within+ a TeX-buffer. However using the mini-buffer might be nicer when we allow+ syntax knowledge to allow completion for example we may complete from+ a Hoogle database.+-}+completeWordB :: EditorM ()+completeWordB = veryQuickCompleteWord+++{-+ This is a very quick and dirty way to complete the current word.+ It works in a similar way to the completion of words in the mini-buffer+ it uses the message buffer to give simple feedback such as,+ "Matches:" and "Complete, but not unique:"++ It is by no means perfect but it's also not bad, pretty usable.+-}+veryQuickCompleteWord :: EditorM ()+veryQuickCompleteWord =+ do (curWord, curWords) <- withBuffer0 wordsAndCurrentWord+ let condition :: String -> Bool+ condition x = (isPrefixOf curWord x) && (x /= curWord)++ preText <- completeInList curWord condition curWords+ if curWord == ""+ then printMsg "No word to complete"+ else withBuffer0 $ insertN $ drop (length curWord) preText++wordsAndCurrentWord :: BufferM (String, [ String ])+wordsAndCurrentWord =+ do curSize <- sizeB+ curText <- readRegionB $ mkRegion 0 curSize+ curWord <- readRegionB =<< regionOfPartB Word Backward+ let curWords = words curText+ return (curWord, curWords)++{-+ Finally obviously we wish to have a much more sophisticated completeword.+ One which spawns a mini-buffer and allows searching in Hoogle databases+ or in other files etc.+-}+
+ Yi/UI/Cocoa.hs view
@@ -0,0 +1,635 @@+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}+--+-- Copyright (c) 2007, 2008 Jean-Philippe Bernardy+-- Copyright (c) 2008 Gustav Munkby+--++-- | This module defines a user interface implemented using Cocoa.++-- For a Cocoa application to work we need to have the Cocoa+-- event-loop running. Since we don't want to re-implement the+-- event-loop in Haskell, we simply dispatch to the Objective-C+-- version and hook into events.+--+-- This however, is not completely trivial, since calling the+-- long-running Objective-C loop causes Haskell code not to be+-- executed at all. Upon receiving an event we must also make+-- sure to dispatch to other Haskell threads in order to make+-- progress. Since the Cocoa run-loop installs and frees an+-- NSAutoreleasePool for every iteration of the loop, we must+-- make sure that we don't allocate an object in one iteration,+-- and then try to use it in the next.+--+-- We therefore use a lock to ensure that only one thread+-- executes Cocoa calls at a time. This means that if a thread+-- claims the lock, it can perform allocation and use Cocoa+-- resources knowing that either the whole operation is performed+-- in one iteration, or it is never even started.++module Yi.UI.Cocoa (start) where++import Prelude hiding (init, error, sequence_, elem, mapM_, mapM, concatMap)++import Yi.Buffer+import Yi.Buffer.HighLevel+import Yi.Editor (Editor, EditorM, withGivenBuffer0, findBufferWith, statusLine, buffers)+import qualified Yi.Editor as Editor+import Yi.Event+import Yi.Debug+import Yi.Buffer.Implementation+import Yi.Monad+import Yi.Style hiding (modeline)+import qualified Yi.UI.Common as Common+import qualified Yi.WindowSet as WS+import qualified Yi.Window as Window+import Yi.Window (Window)+import Paths_yi (getDataFileName)++import Control.Concurrent (yield, threadDelay)+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Monad.Reader (liftIO, when, MonadIO)+import Control.Monad (ap, replicateM_)+import Control.Applicative ((<*>), (<$>))++import Data.IORef+import Data.Maybe+import Data.Unique+import Data.Foldable+import Data.Traversable+import qualified Data.Map as M++import Foundation hiding (length, name, new, parent, error, self, null)+import Foundation.NSObject (init)++import AppKit hiding (windows, start, rect, width, content, prompt, dictionary, icon)+import AppKit.NSWindow (contentView)+import AppKit.NSText (selectedRange)+import qualified AppKit.NSView as NSView++import HOC++import Foreign.C+import Foreign hiding (new)++foreign import ccall "Processes.h TransformProcessType" transformProcessType :: Ptr (CInt) -> CInt -> IO (CInt)+foreign import ccall "Processes.h SetFrontProcess" setFrontProcess :: Ptr (CInt) -> IO (CInt)+foreign import ccall "Processes.h GetCurrentProcess" getCurrentProcess :: Ptr (CInt) -> IO (CInt)+++logNSException :: String -> IO () -> IO ()+logNSException str act =+ catchNS act (\e -> description e >>= haskellString >>=+ logPutStrLn . (("NSException " ++ str ++ ":") ++))++------------------------------------------------------------------------++-- The selector is used since NSEvent#type treats the c enum+-- in a type-safe way, but Cocoa receives values which are not+-- defined in the c enum, which results in a pattern mismatch...+$(declareRenamedSelector "type" "rawType" [t| IO CInt |])+instance Has_rawType (NSEvent a)++-- This declares an application delegate which ensures the application+-- terminates when the last (and only) cocoa window is closed+$(declareClass "YiController" "NSObject")+$(exportClass "YiController" "yc_" [+ InstanceMethod 'applicationShouldTerminateAfterLastWindowClosed -- '+ ])++yc_applicationShouldTerminateAfterLastWindowClosed :: forall t. NSApplication t -> YiController () -> IO Bool+yc_applicationShouldTerminateAfterLastWindowClosed _app _self = return True++------------------------------------------------------------------------++-- This declares an application subclass which enables us to insert+-- ourselves into the application event loop and trap key-events application wide+$(declareClass "YiApplication" "NSApplication")+$(declareSelector "doTick" [t| IO () |])+$(declareSelector "setAppleMenu:" [t| forall t. NSMenu t -> IO () |] )+instance Has_setAppleMenu (NSApplication a)+$(exportClass "YiApplication" "ya_" [+ InstanceVariable "eventChannel" [t| Maybe (Chan Yi.Event.Event) |] [| Nothing |]+ , InstanceVariable "lock" [t| Maybe (MVar ()) |] [| Nothing |]+ , InstanceMethod 'run -- '+ , InstanceMethod 'doTick -- '+ , InstanceMethod 'sendEvent -- '+ ])++ya_doTick :: YiApplication () -> IO ()+ya_doTick self = do+ Just lock <- self #. _lock+ putMVar lock ()+ replicateM_ 4 yield+ takeMVar lock++ya_run :: YiApplication () -> IO ()+ya_run self = do+ -- Schedule a timer that repeatedly invokes ya_doTick in order to have+ -- some Haskell code running all the time. This will prevent other+ -- Haskell threads to stall while waiting for the Cocoa run loop to finish.+ _NSTimer # scheduledTimerWithTimeIntervalTargetSelectorUserInfoRepeats+ 0.05 self (getSelectorForName "doTick") nil True+ super self # run++ya_sendEvent :: forall t. NSEvent t -> YiApplication () -> IO ()+ya_sendEvent event self = logNSException "sendEvent" $ do+ t <- event # rawType+ if t == fromCEnum nsKeyDown+ then self #. _eventChannel >>= handleKeyEvent event+ else super self # sendEvent event++handleKeyEvent :: forall t. NSEvent t -> Maybe (Chan Yi.Event.Event) -> IO ()+handleKeyEvent event ch = do+ mask <- event # modifierFlags+ str <- event # charactersIgnoringModifiers >>= haskellString+ let (k,shift) = case str of+ "\r" -> (Just KEnter, True)+ "\DEL" -> (Just KBS, True)+ "\ESC" -> (Just KEsc, True)+ "\63232" -> (Just KUp, True)+ "\63233" -> (Just KDown, True)+ "\63234" -> (Just KLeft, True)+ "\63235" -> (Just KRight, True)+ "\63273" -> (Just KHome, True)+ "\63275" -> (Just KEnd, True)+ "\63276" -> (Just KPageUp, True)+ "\63277" -> (Just KPageDown, True)+ [c] -> (Just $ KASCII c, False)+ _ -> (Nothing, True)+ case (k,ch) of+ (Just k, Just ch) -> writeChan ch (Event k (modifiers shift mask))+ _ -> return ()++modifierTable :: Bool -> [(CUInt, Modifier)]+modifierTable False = [(bit 18,MCtrl), (bit 19,MMeta)]+modifierTable True = (bit 17,MShift) : modifierTable False++modifiers :: Bool -> CUInt -> [Modifier]+modifiers shift mask = [yi | (cocoa, yi) <- modifierTable shift, (cocoa .&. mask) /= 0]++------------------------------------------------------------------------++-- This declares our special text-view class. The textview interpretes+-- mouse events so that mouse-selection in Yi should function as in any+-- Cocoa application+$(declareClass "YiTextView" "NSTextView")+$(exportClass "YiTextView" "ytv_" [+ InstanceVariable "runBuffer" [t| BufferM () -> IO () |] [| \_ -> return () |]+ , InstanceMethod 'mouseDown -- '+ ])++ytv_mouseDown :: forall t. NSEvent t -> YiTextView () -> IO ()+ytv_mouseDown event self = do+ -- Determine the starting location before tracking mouse+ layout <- self # layoutManager+ container <- self # textContainer+ mousewin <- event # locationInWindow+ NSPoint ex ey <- self # convertPointFromView mousewin nil+ NSPoint ox oy <- self # textContainerOrigin+ let mouse@(NSPoint mx _) = NSPoint (ex - ox) (ey - oy)+ index <- layout # glyphIndexForPointInTextContainer mouse container >>= return . fromEnum+ NSRect (NSPoint cx _) (NSSize cw _) <-+ layout # boundingRectForGlyphRangeInTextContainer (NSRange (toEnum index) 1) container+ let startIndex = if mx - cx < cx + cw - mx then index else index + 1++ -- The super-class deals Cocoa-ishly with mouse events+ super self # mouseDown event++ -- Update our selection marker and position to reflect what Cocoa wants+ NSRange p l <- selectedRange self+ let p1 = fromEnum p+ p2 = p1 + fromEnum l+ runbuf <- self #. _runBuffer+ runbuf $ do+ if p1 == p2+ then do+ unsetMarkB -- Should really be called unsetSelectionMarkB?+ moveTo p1+ else if abs (startIndex - p2) < min (abs (startIndex - p1)) 2+ then setSelectionMarkPointB p2 >> moveTo p1+ else setSelectionMarkPointB p1 >> moveTo p2++------------------------------------------------------------------------++data UI = forall action. UI {+ uiWindow :: NSWindow ()+ ,uiBox :: NSSplitView ()+ ,uiCmdLine :: NSTextField ()+ ,uiBuffers :: IORef (M.Map BufferRef (NSTextStorage ()))+ ,windowCache :: IORef [WinInfo]+ ,uiRunEditor :: EditorM () -> IO ()+ ,uiLock :: MVar ()+ }++data WinInfo = WinInfo+ {+ bufkey :: !BufferRef -- ^ the buffer this window opens to+ ,wkey :: !Unique+ ,textview :: YiTextView ()+ ,modeline :: NSTextField ()+ ,widget :: NSView () -- ^ Top-level widget for this window.+ ,isMini :: Bool+ }++instance Show WinInfo where+ show w = "W" ++ show (hashUnique $ wkey w) ++ " on " ++ show (bufkey w)+++-- | Get the identification of a window.+winkey :: WinInfo -> (Bool, BufferRef)+winkey w = (isMini w, bufkey w)+++mkUI :: UI -> Common.UI+mkUI ui = Common.UI+ {+ Common.main = main ui,+ Common.end = end ,+ Common.suspend = uiWindow ui # performMiniaturize nil,+ Common.refresh = refresh ui,+ Common.prepareAction = prepareAction ui+ }++rect :: Float -> Float -> Float -> Float -> NSRect+rect x y w h = NSRect (NSPoint x y) (NSSize w h)++new, autonew :: forall t. Class (NSObject_ t) -> IO (NSObject t)+new x = do+ d <- description x >>= haskellString+ o <- alloc x+ logPutStrLn $ "New " ++ d+ init o+autonew x = new x >>= autoreleased++autoreleased :: forall t. NSObject t -> IO (NSObject t)+autoreleased o = do+ retain o+ autorelease o+ return o++allSizable, normalWindowMask :: CUInt+allSizable = nsViewWidthSizable .|. nsViewHeightSizable+normalWindowMask =+ nsTitledWindowMask .|. nsResizableWindowMask .|. nsClosableWindowMask .|. nsMiniaturizableWindowMask++initWithContentRect :: NSRect -> NewlyAllocated (NSWindow ()) -> IO (NSWindow ())+initWithContentRect r =+ initWithContentRectStyleMaskBackingDefer r normalWindowMask nsBackingStoreBuffered True+width, height :: NSRect -> Float+width (NSRect _ (NSSize w _)) = w+height (NSRect _ (NSSize _ h)) = h++toNSView :: forall t. ID () -> NSView t+toNSView = castObject++toYiApplication :: forall t1 t2. NSApplication t1 -> YiApplication t2+toYiApplication = castObject+toYiController :: forall t1 t2. NSObject t1 -> YiController t2+toYiController = castObject++setMonospaceFont :: Has_setFont v => v -> IO ()+setMonospaceFont view = do+ f <- _NSFont # userFixedPitchFontOfSize 0.0+ setFont f view++newTextLine :: IO (NSTextField ())+newTextLine = do+ tl <- new _NSTextField+ tl # setAlignment nsLeftTextAlignment+ tl # setAutoresizingMask (nsViewWidthSizable .|. nsViewMaxYMargin)+ tl # setMonospaceFont+ tl # setSelectable True+ tl # setEditable False+ tl # sizeToFit+ return tl++addSubviewWithTextLine :: forall t1 t2. NSView t1 -> NSView t2 -> IO (NSTextField (), NSView ())+addSubviewWithTextLine view parent = do+ container <- new _NSView+ parent # bounds >>= flip setFrame container+ container # setAutoresizingMask allSizable+ view # setAutoresizingMask allSizable+ container # addSubview view++ text <- newTextLine+ container # addSubview text+ parent # addSubview container+ -- Adjust frame sizes, as superb cocoa cannot do this itself...+ txtbox <- text # frame+ winbox <- container # bounds+ view # setFrame (rect 0 (height txtbox) (width winbox) (height winbox - height txtbox))+ text # setFrame (rect 0 0 (width winbox) (height txtbox))++ return (text, container)++-- | Initialise the ui+start :: Chan Yi.Event.Event -> Chan action ->+ Editor -> (EditorM () -> action) ->+ IO Common.UI+start ch outCh _ed runEd = do++ -- Ensure that our command line application is also treated as a gui application+ fptr <- mallocForeignPtrBytes 32 -- way to many bytes, but hey...+ withForeignPtr fptr $ getCurrentProcess+ withForeignPtr fptr $ (flip transformProcessType) 1+ withForeignPtr fptr $ setFrontProcess++ -- Publish Objective-C classes...+ initializeClass_YiApplication+ initializeClass_YiController+ initializeClass_YiTextView++ app <- _YiApplication # sharedApplication >>= return . toYiApplication+ app # setIVar _eventChannel (Just ch)++ lock <- newMVar ()+ app # setIVar _lock (Just lock)++ icon <- getDataFileName "art/yi+lambda-fat.pdf"+ _NSImage # alloc >>=+ initWithContentsOfFile (toNSString icon) >>=+ flip setApplicationIconImage app++ -- Initialize the app delegate, which allows quit-on-window-close+ controller <- autonew _YiController >>= return . toYiController+ app # setDelegate controller++ -- init menus+ mm <- _NSMenu # alloc >>= init+ mm' <- _NSMenu # alloc >>= init+ mm'' <- _NSMenu # alloc >>= init+ app # setMainMenu mm+ app # setAppleMenu mm'+ app # setWindowsMenu mm''+++ -- Create main cocoa window...+ win <- _NSWindow # alloc >>= initWithContentRect (rect 0 0 480 340)+ win # setTitle (toNSString "Yi")+ content <- win # contentView >>= return . toNSView+ content # setAutoresizingMask allSizable++ -- Create yi window container+ winContainer <- new _NSSplitView+ (cmd,_) <- content # addSubviewWithTextLine winContainer+++ -- Activate application window+ win # center+ win # setFrameAutosaveName (toNSString "main")+ win # makeKeyAndOrderFront nil+ app # activateIgnoringOtherApps False++ bufs <- newIORef M.empty+ wc <- newIORef []++ return (mkUI $ UI win winContainer cmd bufs wc (writeChan outCh . runEd) lock)++++-- | Run the main loop+main :: UI -> IO ()+main ui = do+ takeMVar (uiLock ui)+ logPutStrLn "Cocoa main loop running"+ _YiApplication # sharedApplication >>= run++-- | Clean up and go home+end :: IO ()+end = _YiApplication # sharedApplication >>= terminate_ nil++syncWindows :: Editor -> UI -> [(Window, Bool)] -> [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+ | otherwise = do c' <- insertWindowBefore e ui w c+ when focused (setFocus c')+ return (c':) `ap` syncWindows e ui ws (c:cs)+syncWindows e ui ws [] = mapM (insertWindowAtEnd e ui) (map fst ws)+syncWindows _e ui [] cs = mapM_ (removeWindow ui) cs >> return []++setFocus :: WinInfo -> IO ()+setFocus w = do+ logPutStrLn $ "Cocoa focusing " ++ show w+ (textview w) # NSView.window >>= makeFirstResponder (textview w) >> return ()++removeWindow :: UI -> WinInfo -> IO ()+removeWindow _i win = (widget win) # removeFromSuperview++-- | Make A new window+newWindow :: UI -> Bool -> FBuffer -> IO WinInfo+newWindow ui mini b = do+ v <- alloc _YiTextView >>= initWithFrame (rect 0 0 100 100)+ v # setRichText False+ v # setSelectable True+ v # setAlignment nsLeftTextAlignment+ v # sizeToFit+ v # setIVar _runBuffer ((uiRunEditor ui) . withGivenBuffer0 (keyB b))++ (ml, view) <- if mini+ then do+ v # setHorizontallyResizable False+ v # setVerticallyResizable False+ prompt <- newTextLine+ prompt # setStringValue (toNSString (name b))+ prompt # sizeToFit+ prompt # setAutoresizingMask nsViewNotSizable++ prect <- prompt # frame+ vrect <- v # frame++ hb <- _NSView # alloc >>= initWithFrame (rect 0 0 (width prect + width vrect) (height prect))+ v # setFrame (rect (width prect) 0 (width vrect) (height prect))+ v # setAutoresizingMask nsViewWidthSizable+ hb # addSubview prompt+ hb # addSubview v+ hb # setAutoresizingMask nsViewWidthSizable++ brect <- (uiBox ui) # bounds+ hb # setFrame (rect 0 0 (width brect) (height prect))++ (uiBox ui) # addSubview hb+ dummy <- _NSTextField # alloc >>= init++ return (dummy, hb)+ else do+ v # setHorizontallyResizable True+ v # setVerticallyResizable True++ scroll <- new _NSScrollView+ scroll # setDocumentView v+ scroll # setAutoresizingMask allSizable++ scroll # setHasVerticalScroller True+ scroll # setHasHorizontalScroller False+ scroll # setAutohidesScrollers False++ addSubviewWithTextLine scroll (uiBox ui)++ storage <- getTextStorage ui b+ layoutManager v >>= replaceTextStorage storage++ k <- newUnique+ let win = WinInfo {+ bufkey = (keyB b)+ ,wkey = k+ ,textview = v+ ,modeline = ml+ ,widget = view+ ,isMini = mini+ }++ return win++insertWindowBefore :: Editor -> UI -> Window -> WinInfo -> IO WinInfo+insertWindowBefore e i w _c = insertWindow e i w++insertWindowAtEnd :: Editor -> UI -> Window -> IO WinInfo+insertWindowAtEnd e i w = insertWindow e i w++insertWindow :: Editor -> UI -> Window -> IO WinInfo+insertWindow e i win = do+ let buf = findBufferWith (Window.bufkey win) e+ liftIO $ newWindow i (Window.isMini win) buf++refresh :: UI -> Editor -> IO ()+refresh ui e = withMVar (uiLock ui) $ \_ -> logNSException "refresh" $ do+ let ws = Editor.windows e+ let takeEllipsis s = if length s > 132 then take 129 s ++ "..." else s+ (uiCmdLine ui) # setStringValue (toNSString (takeEllipsis (statusLine e)))++ cache <- readRef $ windowCache ui+ forM_ (buffers e) $ \buf -> when (not $ null $ pendingUpdates $ buf) $ do+ storage <- getTextStorage ui buf+ storage # beginEditing+ forM_ (pendingUpdates buf) $ applyUpdate storage+ storage # endEditing+ contents <- storage # string >>= haskellString+ storage # setMonospaceFont -- FIXME: Why is this needed for mini buffers?+ let ((size,p),_) = runBufferDummyWindow buf ((,) <$> sizeB <*> pointB)+ replaceTagsIn (inBounds (p-100) size) (inBounds (p+100) size) buf storage++ (uiWindow ui) # setAutodisplay False -- avoid redrawing while window syncing+ WS.debug "syncing" ws+ logPutStrLn $ "with: " ++ show cache+ cache' <- syncWindows e ui (toList $ WS.withFocus $ ws) cache+ logPutStrLn $ "Yields: " ++ show cache'+ writeRef (windowCache ui) cache'+ (uiBox ui) # adjustSubviews -- FIX: maybe it is not needed+ (uiWindow ui) # setAutodisplay True -- reenable automatic redrawing++ forM_ cache' $ \w ->+ do let buf = findBufferWith (bufkey w) e+ let (p0, _) = runBufferDummyWindow buf pointB+ let (p1, _) = runBufferDummyWindow buf (getSelectionMarkB >>= getMarkPointB)+ (textview w) # setSelectedRange (NSRange (toEnum $ min p0 p1) (toEnum $ abs $ p1-p0))+ (textview w) # scrollRangeToVisible (NSRange (toEnum p0) 0)+ let (txt, _) = runBufferDummyWindow buf getModeLine+ (modeline w) # setStringValue (toNSString txt)+++replaceTagsIn :: forall t. Point -> Point -> FBuffer -> NSTextStorage t -> IO ()+replaceTagsIn from to buf storage = do+ let (styleSpans, _) = runBufferDummyWindow buf (styleRangesB (to - from) from)+ forM_ (zip styleSpans (drop 1 styleSpans)) $ \((l,Style fg bg),(r,_)) -> do+ logPutStrLn $ "Setting style " ++ show fg ++ show bg ++ " on " ++ show l ++ " - " ++ show r+ fg' <- color True fg+ bg' <- color False bg+ let range = NSRange (toEnum l) (toEnum $ r-l)+ storage # addAttributeValueRange nsForegroundColorAttributeName fg' range+ storage # addAttributeValueRange nsBackgroundColorAttributeName bg' range+ where+ color fg Default = if fg then _NSColor # blackColor else _NSColor # whiteColor+ color fg Reverse = if fg then _NSColor # whiteColor else _NSColor # blackColor+ color _g (RGB r g b) = _NSColor # colorWithDeviceRedGreenBlueAlpha ((fromIntegral r)/255) ((fromIntegral g)/255) ((fromIntegral b)/255) 1.0++applyUpdate :: NSTextStorage () -> Update -> IO ()+applyUpdate buf (Insert p s) =+ buf # mutableString >>= insertStringAtIndex (toNSString s) (toEnum p)++applyUpdate buf (Delete p s) =+ buf # mutableString >>= deleteCharactersInRange (NSRange (toEnum p) (toEnum s))++prepareAction :: UI -> IO (EditorM ())+prepareAction _ui = return (return ())+-- NSRange visibleGlyphRange, visibleCharRange;+-- NSLayoutManager *layoutManager = [textView layoutManager];+-- NSTextContainer *textContainer = [textView textContainer];+-- NSPoint containerOrigin = [textView textContainerOrigin];+-- NSRect visibleRect = [textView visibleRect];+--+-- visibleRect.origin.x -= containerOrigin.x; // convert from view+--coordinates to container coordinates+-- visibleRect.origin.y -= containerOrigin.y;+-- visibleGlyphRange = [layoutManager+--glyphRangeForBoundingRect:visibleRect inTextContainer:textContainer];+-- visibleCharRange = [layoutManager+--characterRangeForGlyphRange:visibleGlyphRange actualGlyphRange:NULL];+--do+-- gtkWins <- readRef (windowCache ui)+-- heights <- forM gtkWins $ \w -> do+-- let gtkWin = textview w+-- d <- widgetGetDrawWindow gtkWin+-- (_w,h) <- drawableGetSize d+-- (_,y0) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,0)+-- (i0,_) <- textViewGetLineAtY gtkWin y0+-- l0 <- get i0 textIterLine+-- (_,y1) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,h)+-- (i1,_) <- textViewGetLineAtY gtkWin y1+-- l1 <- get i1 textIterLine+-- return (l1 - l0)+-- modifyMVar (windows ui) $ \ws -> do+-- let (ws', _) = runState (mapM distribute ws) heights+-- return (ws', setBuffer (Window.bufkey $ WS.current ws') >> return ())+--+--distribute :: Window -> State [Int] Window+--distribute win = do+-- h <- gets head+-- modify tail+-- return win {Window.height = h}++getTextStorage :: UI -> FBuffer -> IO (NSTextStorage ())+getTextStorage ui b = do+ let bufsRef = uiBuffers ui+ bufs <- readRef bufsRef+ storage <- case M.lookup (bkey b) bufs of+ Just storage -> return storage+ Nothing -> newTextStorage ui b+ modifyRef bufsRef (M.insert (bkey b) storage)+ return storage++newTextStorage :: UI -> FBuffer -> IO (NSTextStorage ())+newTextStorage _ui b = do+ buf <- new _NSTextStorage+ let (txt, _) = runBufferDummyWindow b (revertPendingUpdatesB >> elemsB)+ buf # mutableString >>= setString (toNSString txt)+ buf # setMonospaceFont+ replaceTagsIn 0 (length txt) b buf+ return buf++-- Debugging helpers++{-++data Hierarchy = View String NSRect [Hierarchy]+ deriving Show++haskellList :: forall t1. NSArray t1 -> IO [ID ()]+haskellList a = a # objectEnumerator >>= helper+ where+ helper enum = do+ e <- enum # nextObject+ if e == nil+ then return []+ else helper enum >>= return . (e :)++mkHierarchy :: forall t. NSView t -> IO Hierarchy+mkHierarchy v = do+ d <- v # description >>= haskellString+ f <- v # frame+ ss <- v # subviews >>= haskellList >>= mapM (mkHierarchy . toNSView)+ return $ View d f ss++-}
+ Yi/UI/Common.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Rank2Types #-}++module Yi.UI.Common where++import Yi.Editor+import Yi.Event+import Control.Concurrent.Chan++data UI = UI+ {+ main :: IO (), -- ^ Main loop+ end :: IO (), -- ^ Clean up+ suspend :: IO (), -- ^ Suspend (or minimize) the program+ refresh :: Editor -> IO (), -- ^ Refresh the UI with the given state+ prepareAction :: IO (EditorM ()) -- ^ Ran before an action is executed+ }++type UIBoot = forall action. (Chan Event -> Chan action -> Editor -> (EditorM () -> action) -> IO UI)
+ Yi/UI/Gtk.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE BangPatterns, ExistentialQuantification #-}++-- Copyright (c) 2007, 2008 Jean-Philippe Bernardy++-- | This module defines a user interface implemented using gtk2hs.++module Yi.UI.Gtk (start) where++import Prelude hiding (error, sequence_, elem, mapM_, mapM, concatMap)++import Yi.Buffer.Implementation (inBounds, Update(..))+import Yi.Buffer+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.Debug+import Yi.Monad+import qualified Yi.UI.Common as Common+import Yi.Style hiding (modeline)+import qualified Yi.WindowSet as WS++import Control.Applicative+import Control.Concurrent ( yield )+import Control.Concurrent.Chan+import Control.Monad (ap)+import Control.Monad.Reader (liftIO, when, MonadIO)+import Control.Monad.State (runState, State, gets, modify)++import Data.Foldable+import Data.IORef+import Data.List ( nub, findIndex, sort )+import Data.Maybe+import Data.Traversable+import Data.Unique+import qualified Data.Map as M++import Graphics.UI.Gtk hiding ( Window, Event, Point, Style )+import qualified Graphics.UI.Gtk as Gtk++------------------------------------------------------------------------++data UI = forall action. UI {+ uiWindow :: Gtk.Window+ , uiBox :: VBox+ , uiCmdLine :: Label+ , uiBuffers :: IORef (M.Map BufferRef TextBuffer)+ , tagTable :: TextTagTable+ , windowCache :: IORef [WinInfo]+ , uiActionCh :: Chan action+ , uiRunEd :: EditorM () -> action+ }++data WinInfo = WinInfo+ {+ bufkey :: !BufferRef -- ^ the buffer this window opens to+ , wkey :: !Unique+ , textview :: TextView+ , modeline :: Label+ , widget :: Box -- ^ Top-level widget for this window.+ , isMini :: Bool+ }++instance Show WinInfo where+ show w = "W" ++ show (hashUnique $ wkey w) ++ " on " ++ show (bufkey w)++-- | Get the identification of a window.+winkey :: WinInfo -> (Bool, BufferRef)+winkey w = (isMini w, bufkey w)++mkUI :: UI -> Common.UI+mkUI ui = Common.UI+ {+ Common.main = main ui,+ Common.end = end,+ Common.suspend = windowIconify (uiWindow ui),+ Common.refresh = refresh ui,+ Common.prepareAction = prepareAction ui+ }++-- | Initialise the ui+start :: Chan Yi.Event.Event -> Chan action ->+ Editor -> (EditorM () -> action) ->+ IO Common.UI+start ch outCh _ed runEd = do+ initGUI++ -- rest.+ win <- windowNew+ windowFullscreen win++ onKeyPress win (processEvent ch)++ vb <- vBoxNew False 1 -- Top-level vbox+ vb' <- vBoxNew False 1++ set win [ containerChild := vb ]+ onDestroy win mainQuit++ cmd <- labelNew Nothing+ set cmd [ miscXalign := 0.01 ]+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Sans mono"+ widgetModifyFont cmd (Just f)++ set vb [ containerChild := vb',+ containerChild := cmd,+ boxChildPacking cmd := PackNatural]++ -- use our magic threads thingy (http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/)+ timeoutAddFull (yield >> return True) priorityDefaultIdle 50++ widgetShowAll win++ bufs <- newIORef M.empty+ wc <- newIORef []+ tt <- textTagTableNew++ let ui = UI win vb' cmd bufs tt wc outCh runEd++ return (mkUI ui)++main :: UI -> IO ()+main _ui =+ do logPutStrLn "GTK main loop running"+ mainGUI++instance Show Gtk.Event where+ show (Key _eventRelease _eventSent _eventTime eventModifier' _eventWithCapsLock _eventWithNumLock+ _eventWithScrollLock _eventKeyVal eventKeyName' eventKeyChar')+ = show eventModifier' ++ " " ++ show eventKeyName' ++ " " ++ show eventKeyChar'+ show _ = "Not a key event"++instance Show Gtk.Modifier where+ show Control = "Ctrl"+ show Alt = "Alt"+ show Shift = "Shift"+ show Apple = "Apple"+ show Compose = "Compose"++processEvent :: Chan Event -> Gtk.Event -> IO Bool+processEvent ch ev = do+ -- logPutStrLn $ "Gtk.Event: " ++ show ev+ -- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)+ case gtkToYiEvent ev of+ Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev+ Just e -> writeChan ch e+ return True++gtkToYiEvent :: Gtk.Event -> Maybe Event+gtkToYiEvent (Key {eventKeyName = keyName, eventModifier = modifier, eventKeyChar = char})+ = fmap (\k -> Event k $ (nub $ (if isShift then filter (not . (== MShift)) else id) $ concatMap modif modifier)) key'+ where (key',isShift) =+ case char of+ Just c -> (Just $ KASCII c, True)+ Nothing -> (M.lookup keyName keyTable, False)+ modif Control = [MCtrl]+ modif Alt = [MMeta]+ modif Shift = [MShift]+ modif Apple = []+ modif Compose = []+gtkToYiEvent _ = Nothing++-- | Map GTK long names to Keys+keyTable :: M.Map String Key+keyTable = M.fromList+ [("Down", KDown)+ ,("Up", KUp)+ ,("Left", KLeft)+ ,("Right", KRight)+ ,("Home", KHome)+ ,("End", KEnd)+ ,("BackSpace", KBS)+ ,("Delete", KDel)+ ,("Page_Up", KPageUp)+ ,("Page_Down", KPageDown)+ ,("Insert", KIns)+ ,("Escape", KEsc)+ ,("Return", KEnter)+ ,("Tab", KASCII '\t')+ ]++-- | Clean up and go home+end :: IO ()+end = mainQuit++-- | Synchronize the windows displayed by GTK with the status of windows in the Core.+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+ | otherwise = do c' <- insertWindowBefore e ui w c+ when focused (setFocus c')+ return (c':) `ap` syncWindows e ui ws (c:cs)+syncWindows e ui ws [] = mapM (insertWindowAtEnd e ui) (map fst ws)+syncWindows _e ui [] cs = mapM_ (removeWindow ui) cs >> return []++setFocus :: WinInfo -> IO ()+setFocus w = do+ logPutStrLn $ "gtk focusing " ++ show w+ hasFocus <- widgetIsFocus (textview w)+ when (not hasFocus) $ widgetGrabFocus (textview w)++removeWindow :: UI -> WinInfo -> IO ()+removeWindow i win = containerRemove (uiBox i) (widget win)++instance Show Click where+ show x = case x of+ SingleClick -> "SingleClick "+ DoubleClick -> "DoubleClick "+ TripleClick -> "TripleClick "+ ReleaseClick -> "ReleaseClick"++handleClick :: UI -> WinInfo -> Gtk.Event -> IO Bool+handleClick ui w event = do+ -- logPutStrLn $ "Click: " ++ show (eventX e, eventY e, eventClick e)++ -- retrieve the clicked offset.+ let tv = textview w+ let wx = round (eventX event)+ let wy = round (eventY event)+ (bx, by) <- textViewWindowToBufferCoords tv TextWindowText (wx,wy)+ iter <- textViewGetIterAtLocation tv bx by+ p1 <- get iter textIterOffset++ -- maybe focus the window+ logPutStrLn $ "Clicked inside window: " ++ show w+ wCache <- readIORef (windowCache ui)+ let Just idx = findIndex ((wkey w ==) . wkey) wCache+ focusWindow = modifyWindows (WS.focusIndex idx)+ logPutStrLn $ "Will focus to index: " ++ show (findIndex ((wkey w ==) . wkey) wCache)++ let editorAction = do+ b <- gets $ (bkey . findBufferWith (bufkey w))+ case (eventClick event, eventButton event) of+ (SingleClick, LeftButton) -> do+ focusWindow+ withGivenBuffer0 b $ moveTo p1 -- as a side effect we forget the prefered column+ (SingleClick, _) -> focusWindow+ (ReleaseClick, LeftButton) -> do+ p0 <- withGivenBuffer0 b $ pointB+ if p1 == p0+ then withGivenBuffer0 b unsetMarkB+ else do txt <- withGivenBuffer0 b $ do m <- getSelectionMarkB+ setMarkPointB m p1+ let [i,j] = sort [p1,p0]+ nelemsB (j-i) i+ modify (\e ->e {yreg = txt})+ (ReleaseClick, MiddleButton) -> do+ txt <- gets yreg+ withGivenBuffer0 b $ do+ unsetMarkB+ moveTo p1+ insertN txt++ _ -> return ()++ case ui of+ UI {uiActionCh = ch, uiRunEd = run} -> writeChan ch (run editorAction)+ return True+++-- | Make A new window+newWindow :: UI -> Bool -> FBuffer -> IO WinInfo+newWindow ui mini b = do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Sans mono"++ ml <- labelNew Nothing+ widgetModifyFont ml (Just f)+ set ml [ miscXalign := 0.01 ] -- so the text is left-justified.++ v <- textViewNew+ textViewSetWrapMode v WrapChar+ widgetModifyFont v (Just f)++ box <- if mini+ then do+ widgetSetSizeRequest v (-1) 1++ prompt <- labelNew (Just $ name b)+ widgetModifyFont prompt (Just f)++ hb <- hBoxNew False 1+ set hb [ containerChild := prompt,+ containerChild := v,+ boxChildPacking prompt := PackNatural,+ boxChildPacking v := PackGrow]++ return (castToBox hb)+ else do+ scroll <- scrolledWindowNew Nothing Nothing+ set scroll [scrolledWindowPlacement := CornerTopRight,+ scrolledWindowVscrollbarPolicy := PolicyAlways,+ scrolledWindowHscrollbarPolicy := PolicyAutomatic,+ containerChild := v]++ vb <- vBoxNew False 1+ set vb [ containerChild := scroll,+ containerChild := ml,+ boxChildPacking ml := PackNatural]+ return (castToBox vb)++ gtkBuf <- getGtkBuffer ui b++ textViewSetBuffer v gtkBuf++ k <- newUnique+ let win = WinInfo {+ bufkey = (keyB b)+ , wkey = k+ , textview = v+ , modeline = ml+ , widget = box+ , isMini = mini+ }+ return win++insertWindowBefore :: Editor -> UI -> Window -> WinInfo -> IO WinInfo+insertWindowBefore e i w _c = insertWindow e i w++insertWindowAtEnd :: Editor -> UI -> Window -> IO WinInfo+insertWindowAtEnd e i w = insertWindow e i w++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+ set (uiBox i) [containerChild := widget w,+ boxChildPacking (widget w) := if isMini w then PackNatural else PackGrow]+ textview w `onButtonRelease` handleClick i w+ textview w `onButtonPress` handleClick i w+ widgetShowAll (widget w)+ return w++refresh :: UI -> Editor -> IO ()+refresh ui e = do+ 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+ forM_ (buffers e) $ \buf -> when (not $ null $ pendingUpdates $ buf) $ do+ gtkBuf <- getGtkBuffer ui buf+ forM_ (pendingUpdates buf) $ applyUpdate gtkBuf+ let ((size,p),_) = runBufferDummyWindow buf ((,) <$> sizeB <*> pointB)+ replaceTagsIn ui (inBounds (p-100) size) (inBounds (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+ gtkBuf <- getGtkBuffer ui buf++ let (p0, _) = runBufferDummyWindow buf pointB+ let (p1, _) = runBufferDummyWindow buf (getSelectionMarkB >>= getMarkPointB)+ insertMark <- textBufferGetInsert gtkBuf+ i <- textBufferGetIterAtOffset gtkBuf p0+ i' <- textBufferGetIterAtOffset gtkBuf p1+ textBufferSelectRange gtkBuf i i'+ textViewScrollMarkOnscreen (textview w) insertMark+ let (txt, _) = runBufferDummyWindow buf getModeLine+ set (modeline w) [labelText := txt]++replaceTagsIn :: UI -> Point -> Point -> FBuffer -> TextBuffer -> IO ()+replaceTagsIn ui from to buf gtkBuf = do+ i <- textBufferGetIterAtOffset gtkBuf from+ i' <- textBufferGetIterAtOffset gtkBuf to+ let (styleSpans, _) = runBufferDummyWindow buf (styleRangesB (to - from) from)+ textBufferRemoveAllTags gtkBuf i i'+ forM_ (zip styleSpans (drop 1 styleSpans)) $ \((l,style),(r,_)) -> do+ f <- textBufferGetIterAtOffset gtkBuf l+ t <- textBufferGetIterAtOffset gtkBuf r+ tag <- styleToTag ui style+ textBufferApplyTag gtkBuf tag f t++applyUpdate :: TextBuffer -> Update -> IO ()+applyUpdate buf (Insert p s) = do+ i <- textBufferGetIterAtOffset buf p+ textBufferInsert buf i s++applyUpdate buf (Delete p s) = do+ i0 <- textBufferGetIterAtOffset buf p+ i1 <- textBufferGetIterAtOffset buf (p + s)+ textBufferDelete buf i0 i1++styleToTag :: UI -> Style -> IO TextTag+styleToTag ui (Style fg _bg) = do+ let fgText = colorToText fg+ mtag <- textTagTableLookup (tagTable ui) fgText+ case mtag of+ Just x -> return x+ Nothing -> do x <- textTagNew (Just fgText)+ set x [textTagForeground := fgText]+ textTagTableAdd (tagTable ui) x+ return x++prepareAction :: UI -> IO (EditorM ())+prepareAction ui = do+ -- compute the heights of all windows (in number of lines)+ gtkWins <- readRef (windowCache ui)+ heights <- forM gtkWins $ \w -> do+ let gtkWin = textview w+ d <- widgetGetDrawWindow gtkWin+ (_w,h) <- drawableGetSize d+ (_,y0) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,0)+ (i0,_) <- textViewGetLineAtY gtkWin y0+ l0 <- get i0 textIterLine+ (_,y1) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,h)+ (i1,_) <- textViewGetLineAtY gtkWin y1+ l1 <- get i1 textIterLine+ return (l1 - l0)+ -- updates the heights of the windows+ return $ modifyWindows (\ws -> fst $ runState (mapM distribute ws) heights)++distribute :: Window -> State [Int] Window+distribute win = do+ h <- gets head+ modify tail+ return win {Window.height = h}++getGtkBuffer :: UI -> FBuffer -> IO TextBuffer+getGtkBuffer ui b = do+ let bufsRef = uiBuffers ui+ bufs <- readRef bufsRef+ gtkBuf <- case M.lookup (bkey b) bufs of+ Just gtkBuf -> return gtkBuf+ Nothing -> newGtkBuffer ui b+ modifyRef bufsRef (M.insert (bkey b) gtkBuf)+ return gtkBuf++-- FIXME: when a buffer is deleted its GTK counterpart should be too.+newGtkBuffer :: UI -> FBuffer -> IO TextBuffer+newGtkBuffer ui b = do+ buf <- textBufferNew (Just (tagTable ui))+ let (txt, _) = runBufferDummyWindow b (revertPendingUpdatesB >> elemsB)+ textBufferSetText buf txt+ replaceTagsIn ui 0 (length txt) b buf+ return buf
+ Yi/UI/Vty.hs view
@@ -0,0 +1,377 @@+--+-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--+-- Derived from: riot/UI.hs+--+-- Copyright (c) Tuomo Valkonen 2004.+--+-- Released under the same license.+--++-- | This module defines a user interface implemented using ncurses.++module Yi.UI.Vty (start) where++import Prelude hiding (error, concatMap, sum, mapM, sequence)++import Control.Concurrent+import Control.Concurrent.Chan+import Control.Exception+import Control.Monad (forever)+import Control.Monad.State (runState, State, gets, modify, get, put)+import Control.Monad.Trans (liftIO, MonadIO)+import Control.Arrow (second)+import Data.Char (ord,chr)+import Data.Foldable+import Data.IORef+import Data.List (partition)+import Data.Maybe+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.Debug+import Yi.Editor+import Yi.Event+import Yi.Monad+import Yi.Style+import Yi.Vty hiding (def, black, red, green, yellow, blue, magenta, cyan, white)+import Yi.WindowSet as WS+import qualified Data.ByteString.Char8 as B+import qualified Yi.UI.Common as Common+import Yi.Window+------------------------------------------------------------------------++data Rendered = + Rendered {+ picture :: !Image -- ^ the picture currently displayed.+ ,cursor :: !(Maybe (Int,Int)) -- ^ cursor point on the above+ }+++++data UI = UI { + vty :: Vty -- ^ Vty+ ,scrsize :: IORef (Int,Int) -- ^ screen size+ ,uiThread :: ThreadId+ ,uiRefresh :: MVar ()+ ,uiEditor :: IORef Editor+ }+mkUI :: UI -> Common.UI+mkUI ui = Common.UI + {+ Common.main = main ui,+ Common.end = end ui,+ Common.suspend = raiseSignal sigTSTP,+ Common.refresh = scheduleRefresh ui,+ Common.prepareAction = prepareAction ui+ }+++-- | Initialise the ui+start :: Chan Yi.Event.Event -> Chan action ->+ Editor -> (EditorM () -> action) -> + IO Common.UI+start ch _outCh editor _runEd = do+ liftIO $ do + v <- mkVty+ (x0,y0) <- Yi.Vty.getSize v+ sz <- newIORef (y0,x0)+ -- fork input-reading thread. important to block *thread* on getKey+ -- otherwise all threads will block waiting for input+ t <- myThreadId+ tuiRefresh <- newEmptyMVar+ editorRef <- newIORef editor+ let result = UI v sz t tuiRefresh editorRef+ -- | Action to read characters into a channel+ getcLoop = forever $ getKey >>= writeChan ch++ -- | Read a key. UIs need to define a method for getting events.+ getKey = do + event <- getEvent v+ case event of + (EvResize x y) -> do logPutStrLn $ "UI: EvResize: " ++ show (x,y)+ writeIORef sz (y,x) >> readRef (uiEditor result) >>= refresh result >> getKey+ _ -> return (fromVtyEvent event)+ forkIO $ getcLoop+ return (mkUI result)+ ++main :: UI -> IO ()+main ui = do+ let+ -- | When the editor state isn't being modified, refresh, then wait for+ -- it to be modified again. + refreshLoop :: IO ()+ refreshLoop = forever $ do + logPutStrLn "waiting for refresh"+ takeMVar (uiRefresh ui)+ handleJust ioErrors (\except -> do + logPutStrLn "refresh crashed with IO Error"+ logError $ show $ except)+ (readRef (uiEditor ui) >>= refresh ui >> return ())+ readRef (uiEditor ui) >>= scheduleRefresh ui+ logPutStrLn "refreshLoop started"+ refreshLoop+ ++-- | Clean up and go home+end :: UI -> IO ()+end i = do + Yi.Vty.shutdown (vty i)+ throwTo (uiThread i) (ExitException ExitSuccess)++fromVtyEvent :: Yi.Vty.Event -> Yi.Event.Event+fromVtyEvent (EvKey k mods) = Event (fromVtyKey k) (map fromVtyMod mods)+fromVtyEvent _ = error "fromVtyEvent: unsupported event encountered."+++fromVtyKey :: Yi.Vty.Key -> Yi.Event.Key+fromVtyKey (Yi.Vty.KEsc ) = Yi.Event.KEsc +fromVtyKey (Yi.Vty.KFun x ) = Yi.Event.KFun x +fromVtyKey (Yi.Vty.KPrtScr ) = Yi.Event.KPrtScr +fromVtyKey (Yi.Vty.KPause ) = Yi.Event.KPause +fromVtyKey (Yi.Vty.KASCII c ) = Yi.Event.KASCII c +fromVtyKey (Yi.Vty.KBS ) = Yi.Event.KBS +fromVtyKey (Yi.Vty.KIns ) = Yi.Event.KIns +fromVtyKey (Yi.Vty.KHome ) = Yi.Event.KHome +fromVtyKey (Yi.Vty.KPageUp ) = Yi.Event.KPageUp +fromVtyKey (Yi.Vty.KDel ) = Yi.Event.KDel +fromVtyKey (Yi.Vty.KEnd ) = Yi.Event.KEnd +fromVtyKey (Yi.Vty.KPageDown) = Yi.Event.KPageDown +fromVtyKey (Yi.Vty.KNP5 ) = Yi.Event.KNP5 +fromVtyKey (Yi.Vty.KUp ) = Yi.Event.KUp +fromVtyKey (Yi.Vty.KMenu ) = Yi.Event.KMenu +fromVtyKey (Yi.Vty.KLeft ) = Yi.Event.KLeft +fromVtyKey (Yi.Vty.KDown ) = Yi.Event.KDown +fromVtyKey (Yi.Vty.KRight ) = Yi.Event.KRight +fromVtyKey (Yi.Vty.KEnter ) = Yi.Event.KEnter ++fromVtyMod :: Yi.Vty.Modifier -> Yi.Event.Modifier+fromVtyMod Yi.Vty.MShift = Yi.Event.MShift+fromVtyMod Yi.Vty.MCtrl = Yi.Event.MCtrl+fromVtyMod Yi.Vty.MMeta = Yi.Event.MMeta+fromVtyMod Yi.Vty.MAlt = Yi.Event.MMeta++prepareAction :: UI -> IO (EditorM ())+prepareAction ui = do+ (yss,xss) <- readRef (scrsize ui)+ return $ do+ e <- get+ modifyWindows $ \ws0 -> + let ws1 = computeHeights yss ws0+ zzz = fmap (scrollAndRenderWindow e (uistyle e) xss) (WS.withFocus ws1)+ -- note that the rendering won't actually be performed because of laziness.+ in (fmap fst zzz)+++-- | Redraw the entire terminal from the UI.+-- Among others, this re-computes the heights and widths of all the windows.++-- Two points remain: horizontal scrolling, and tab handling.+refresh :: UI -> Editor -> IO (WS.WindowSet Window)+refresh ui e = do+ let ws0 = windows e+ logPutStrLn "refreshing screen."+ (yss,xss) <- readRef (scrsize ui)+ let ws1 = computeHeights yss ws0+ cmd = statusLine e+ zzz = fmap (scrollAndRenderWindow e (uistyle e) xss) (WS.withFocus ws1)++ let startXs = scanrT (+) 0 (fmap height ws1)+ wImages = fmap picture $ fmap snd $ zzz+ + WS.debug "Drawing: " ws1+ logPutStrLn $ "startXs: " ++ show startXs+ Yi.Vty.update (vty $ ui) + pic {pImage = vertcat (toList wImages) <-> withStyle (window $ uistyle e) (take xss $ cmd ++ repeat ' '),+ pCursor = case cursor (snd $ WS.current zzz) of+ Just (y,x) -> Cursor x (y + WS.current startXs)+ Nothing -> NoCursor+ -- This can happen if the user resizes the window. + -- Not really nice, but upon the next refresh the cursor will show.+ }++ return (fmap fst zzz)++scanrT :: (Int -> Int -> Int) -> Int -> WindowSet Int -> WindowSet Int+scanrT (+*+) k t = fst $ runState (mapM f t) k+ where f x = do s <- get+ let s' = s +*+ x+ put s'+ return s+ ++-- | Scrolls the window to show the point if needed+scrollAndRenderWindow :: Editor -> UIStyle -> Int -> (Window, Bool) -> (Window, Rendered)+scrollAndRenderWindow e sty width (win,hasFocus) = (win' {bospnt = bos}, rendered)+ where b = findBufferWith (bufkey win) e+ (point, _) = runBufferDummyWindow b pointB+ win' = if not hasFocus || pointInWindow point win then win else showPoint e win+ (rendered, bos) = drawWindow e sty hasFocus width win'++-- | return index of Sol on line @n@ above current line+indexOfSolAbove :: Int -> BufferM Int+indexOfSolAbove n = savingPointB $ do+ gotoLnFrom (negate n)+ pointB++showPoint :: Editor -> Window -> Window +showPoint e w = result+ where b = findBufferWith (bufkey w) e+ (result, _) = runBufferDummyWindow b $ + do ln <- curLn+ let gap = min (ln-1) (height w `div` 2)+ i <- indexOfSolAbove gap+ return w {tospnt = i}++-- | Draw a window+-- TODO: horizontal scrolling.+drawWindow :: Editor -> UIStyle -> Bool -> Int -> Window -> (Rendered, Int)+drawWindow e sty focused w win = (Rendered { picture = pict,cursor = cur}, bos)+ + where+ b = findBufferWith (bufkey win) e+ m = not (isMini win)+ off = if m then 1 else 0+ h' = height win - off+ wsty = styleToAttr (window sty)+ selsty = styleToAttr (selected sty)+ eofsty = eof sty+ (selreg, _) = runBufferDummyWindow b getSelectRegionB+ (point, _) = runBufferDummyWindow b pointB+ (bufData, _) = runBufferDummyWindow b (nelemsBH (w*h') (tospnt win)) -- read enough chars from the buffer.+ prompt = if isMini win then name b else ""++ (rendered,bos,cur) = drawText h' w+ (tospnt win - length prompt) + point selreg+ selsty wsty + (zip prompt (repeat wsty) ++ map (second styleToAttr) bufData ++ [(' ',attr)])+ -- we always add one character which can be used to position the cursor at the end of file+ + (modeLine0, _) = runBufferDummyWindow b getModeLine+ modeLine = if m then Just modeLine0 else Nothing+ modeLines = map (withStyle (modeStyle sty) . take w . (++ repeat ' ')) $ maybeToList $ modeLine+ modeStyle = if focused then modeline_focused else modeline + filler = take w (windowfill e : repeat ' ')+ + pict = vertcat (take h' (rendered ++ repeat (withStyle eofsty filler)) ++ modeLines)+ +-- | Renders text in a rectangle.+-- This also returns +-- * the index of the last character fitting in the rectangle+-- * the position of the Point in (x,y) coordinates, if in the window.+drawText :: Int -- ^ The height of the part of the window we are in+ -> Int -- ^ The width of the part of the window we are in+ -> Point -- ^ The position of the first character to draw+ -> Point -- ^ The position of the cursor+ -> Region -- ^ The selected region+ -> Attr -- ^ The attribute with which to draw selected text+ -> 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,Attr)] -- ^ The data to draw.+ -> ([Image], Point, Maybe (Int,Int))+drawText h w topPoint point selreg selsty wsty bufData+ | h == 0 || w == 0 = ([], topPoint, Nothing)+ | otherwise = (rendered_lines, bottomPoint, pntpos)+ where + -- | Remember the point of each char+ annotateWithPoint text = zipWith (\(c,a) p -> (c,(a,p))) text [topPoint..] ++ lns0 = take h $ concatMap (wrapLine w) $ map (concatMap expandGraphic) $ lines' $ annotateWithPoint $ bufData++ bottomPoint = case lns0 of + [] -> topPoint + _ -> snd $ snd $ last $ last $ lns0++ pntpos = listToMaybe [(y,x) | (y,l) <- zip [0..] lns0, (x,(_char,(_attr,p))) <- zip [0..] l, p == point]++ -- 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 -> Attr -> Attr+ pointStyle x a + | x == point = a+ | x `inRegion` selreg + && selsty /= wsty = selsty+ | otherwise = a++ fillColorLine :: [(Char, (Attr, Point))] -> Image+ fillColorLine [] = renderHFill attr ' ' w+ fillColorLine l = horzcat (map colorChar l) + <|>+ renderHFill (pointStyle x a) ' ' (w - length l)+ where (_,(a,x)) = last l++ -- | Cut a string in lines separated by a '\n' char. Note+ -- that we add a blank character where the \n was, so the+ -- cursor can be positioned there.++ lines' :: [(Char,a)] -> [[(Char,a)]]+ lines' [] = []+ lines' s = case s' of+ [] -> [l]+ ((_,x):s'') -> (l++[(' ',x)]) : lines' s''+ where+ (l, s') = break ((== '\n') . fst) s++ wrapLine :: Int -> [x] -> [[x]]+ wrapLine _ [] = []+ wrapLine n l = let (x,rest) = splitAt n l in x : wrapLine n rest+ + expandGraphic (c,p) + | ord c < 32 = [('^',p),(chr (ord c + 64),p)]+ | ord c < 128 = [(c,p)]+ | otherwise = zip ('\\':show (ord c)) (repeat p)+ +++-- TODO: The above will actually require a bit of work, in order to handle tabs.++withStyle :: Style -> String -> Image+withStyle sty str = renderBS (styleToAttr sty) (B.pack str)+++------------------------------------------------------------------------+++-- | Schedule a refresh of the UI.+scheduleRefresh :: UI -> Editor -> IO ()+scheduleRefresh ui e = do+ writeRef (uiEditor ui) e+ logPutStrLn "scheduleRefresh"+ tryPutMVar (uiRefresh ui) ()+ return ()+-- The non-blocking behviour was set up with this in mind: if the display+-- thread is not able to catch up with the editor updates (possible since+-- display is much more time consuming than simple editor operations),+-- then there will be fewer display refreshes. ++-- | Calculate window heights, given all the windows and current height.+-- (No specific code for modelines)+computeHeights :: Int -> WindowSet Window -> WindowSet Window+computeHeights totalHeight ws = result+ where (mwls, wls) = partition isMini (toList ws)+ (y,r) = getY (totalHeight - length mwls) (length wls) + (result, _) = runState (Data.Traversable.mapM distribute ws) ((y+r-1) : repeat y)++distribute :: Window -> State [Int] Window+distribute win = case isMini win of+ True -> return win {height = 1}+ False -> do h <- gets head+ modify tail+ return win {height = h}++getY :: Int -> Int -> (Int,Int)+getY screenHeight 0 = (screenHeight, 0)+getY screenHeight numberOfWindows = screenHeight `quotRem` numberOfWindows+
+ Yi/Undo.hs view
@@ -0,0 +1,170 @@+--+-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++--+-- | 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.Undo (+ emptyUR+ , addUR+ , setSavedPointUR+ , manyUR+ , undoInteractivePoint+ , undoUR+ , redoUR+ , isUnchangedUList+ , reverseUpdate+ , getActionB+ , URList {- abstractly -}+ , Change(AtomicChange, InteractivePoint)+ , changeUpdates+ ) where++import Yi.Buffer.Implementation ++data Change = SavedFilePoint+ | InteractivePoint+ | AtomicChange Update+ deriving Show++changeUpdates :: Change -> [Update]+changeUpdates (AtomicChange u) = [u]+changeUpdates SavedFilePoint = []+changeUpdates InteractivePoint = []+++-- | A URList consists of an undo and a redo list.+data URList = URList [Change] [Change]+ deriving Show++-- | 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+emptyUR :: URList+emptyUR = 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.+addUR :: Change -> URList -> URList+addUR InteractivePoint ur@(URList (InteractivePoint:_) _) = ur+addUR 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.+setSavedPointUR :: URList -> URList+setSavedPointUR (URList undos redos) =+ URList (SavedFilePoint : cleanUndos) cleanRedos+ where+ cleanUndos = filter isNotSavedFilePoint undos+ cleanRedos = filter isNotSavedFilePoint redos+ isNotSavedFilePoint :: Change -> Bool+ isNotSavedFilePoint SavedFilePoint = False+ isNotSavedFilePoint _ = True++undoInteractivePoint :: URList -> BufferImpl -> (BufferImpl, (URList, [Change]))+undoInteractivePoint (URList (InteractivePoint:cs) rs) b = (b, (URList cs (InteractivePoint:rs), []))+undoInteractivePoint ur b = (b, (ur, []))++-- | repeat ur action until we find an InteractivePoint.+manyUR :: (URList -> t -> (t, (URList, [a])))-> URList -> t -> (t, (URList, [a]))+manyUR _ ur@(URList [] _) b = (b, (ur, []))+manyUR _ ur@(URList [SavedFilePoint] _) b = (b, (ur, []))+manyUR _ ur@(URList (InteractivePoint:_) _) b = (b, (ur, []))+manyUR f ur@(URList _ _) b = + let (b', (ur', cs')) = f ur b+ (b'', (ur'', cs'')) = manyUR f ur' b'+ in (b'', (ur'', cs'' ++ cs'))++-- | Undo the last action that mutated the buffer contents. The action's+-- inverse is added to the redo list. +undoUR :: URList -> BufferImpl -> (BufferImpl, (URList, [Change]))+undoUR u@(URList [] _) b = (b, (u, []))+undoUR u@(URList [SavedFilePoint] _) b = (b, (u, []))+undoUR (URList (SavedFilePoint : rest) rs) b = + undoUR (URList rest (SavedFilePoint : rs)) b+undoUR (URList (u:us) rs) b = + let (b', r) = getActionB u b + in (b', (URList us (r:rs), [u]))++-- | Redo the last action that mutated the buffer contents. The action's+-- inverse is added to the undo list.+redoUR :: URList -> BufferImpl -> (BufferImpl, (URList, [Change]))+redoUR u@(URList _ []) b = (b, (u, []))+redoUR u@(URList _ [SavedFilePoint]) b = (b, (u, []))+redoUR (URList us (SavedFilePoint : rest)) b =+ redoUR (URList (SavedFilePoint : us) rest) b+redoUR (URList us (r:rs)) b =+ let (b', u) = getActionB r b+ in (b', (URList (u:us) rs, [u]))++-- | isUnchangedUndoList. @True@ if the undo list is either empty or we are at a+-- SavedFilePoint indicated 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.+isUnchangedUList :: URList -> Bool+isUnchangedUList (URList (InteractivePoint:us) rs) = isUnchangedUList (URList us rs)+isUnchangedUList (URList [] _) = False+isUnchangedUList (URList (SavedFilePoint : _) _) = True+isUnchangedUList (URList _ _) = False++-- | Given a Update, apply it to the buffer, and return the+-- Update that reverses it.+getActionB :: Change -> BufferImpl -> (BufferImpl, Change)+getActionB (AtomicChange u) b = (applyUpdateI u (moveToI (updatePoint u) b), + AtomicChange (reverseUpdate u b))+getActionB c b = (b,c)++-- | Reverse the given update+reverseUpdate :: Update -> BufferImpl -> Update+reverseUpdate (Delete p n) b = Insert p (nelemsBI n p b)+reverseUpdate (Insert p cs) _ = Delete p (length cs)++
+ Yi/Vty.hs view
@@ -0,0 +1,83 @@+module Yi.Vty+ (+ styleToAttr,+ defaultSty,++ module Vty+ ) where++import Yi.Style as Style+import Graphics.Vty as Vty++------------------------------------------------------------------------++--+-- Combine attribute with another attribute+--+boldA, reverseA, nullA :: Vty.Attr -> Vty.Attr+boldA = setBold+reverseA = setRV+nullA = id++------------------------------------------------------------------------++newtype CColor = CColor (Vty.Attr -> Vty.Attr, Vty.Color)+--+-- | Map Style rgb rgb colours to ncurses pairs+-- TODO a generic way to turn an rgb into the nearest curses color+--+style2curses :: Style -> (CColor, CColor)+style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg)+{-# INLINE style2curses #-}++fgCursCol :: Style.Color -> CColor+fgCursCol c = case c of+ RGB 0 0 0 -> CColor (nullA, Vty.black)+ RGB 128 128 128 -> CColor (boldA, Vty.black)+ RGB 139 0 0 -> CColor (nullA, Vty.red)+ RGB 255 0 0 -> CColor (boldA, Vty.red)+ RGB 0 100 0 -> CColor (nullA, Vty.green)+ RGB 0 128 0 -> CColor (boldA, Vty.green)+ RGB 165 42 42 -> CColor (nullA, Vty.yellow)+ RGB 255 255 0 -> CColor (boldA, Vty.yellow)+ RGB 0 0 139 -> CColor (nullA, Vty.blue)+ RGB 0 0 255 -> CColor (boldA, Vty.blue)+ RGB 128 0 128 -> CColor (nullA, Vty.magenta)+ RGB 255 0 255 -> CColor (boldA, Vty.magenta)+ RGB 0 139 139 -> CColor (nullA, Vty.cyan)+ RGB 0 255 255 -> CColor (boldA, Vty.cyan)+ RGB 165 165 165 -> CColor (nullA, Vty.white)+ RGB 255 255 255 -> CColor (boldA, Vty.white)+ Default -> CColor (nullA, Vty.def)+ Reverse -> CColor (reverseA, Vty.def)+ _ -> CColor (nullA, Vty.black) -- NB++bgCursCol :: Style.Color -> CColor+bgCursCol c = case c of+ RGB 0 0 0 -> CColor (nullA, Vty.black)+ RGB 128 128 128 -> CColor (nullA, Vty.black)+ RGB 139 0 0 -> CColor (nullA, Vty.red)+ RGB 255 0 0 -> CColor (nullA, Vty.red)+ RGB 0 100 0 -> CColor (nullA, Vty.green)+ RGB 0 128 0 -> CColor (nullA, Vty.green)+ RGB 165 42 42 -> CColor (nullA, Vty.yellow)+ RGB 255 255 0 -> CColor (nullA, Vty.yellow)+ RGB 0 0 139 -> CColor (nullA, Vty.blue)+ RGB 0 0 255 -> CColor (nullA, Vty.blue)+ RGB 128 0 128 -> CColor (nullA, Vty.magenta)+ RGB 255 0 255 -> CColor (nullA, Vty.magenta)+ RGB 0 139 139 -> CColor (nullA, Vty.cyan)+ RGB 0 255 255 -> CColor (nullA, Vty.cyan)+ RGB 165 165 165 -> CColor (nullA, Vty.white)+ RGB 255 255 255 -> CColor (nullA, Vty.white)+ Default -> CColor (nullA, Vty.def)+ Reverse -> CColor (reverseA, Vty.def)+ _ -> CColor (nullA, Vty.white) -- NB++defaultSty :: Style+defaultSty = Style Default Default++styleToAttr :: Style -> Vty.Attr+styleToAttr = ccolorToAttr . style2curses+ where ccolorToAttr ((CColor (fmod, fcolor)), (CColor (bmod, bcol))) = + fmod . bmod . setFG fcolor . setBG bcol $ attr
+ Yi/Window.hs view
@@ -0,0 +1,33 @@+--+-- Copyright (c) 2008 JP Bernardy+--+--++module Yi.Window where++import Yi.Buffer.Implementation (Point)+type BufferRef = Int++------------------------------------------------------------------------+-- | A window onto a buffer.++data Window = Window {+ isMini :: !Bool -- ^ regular or mini window?+ ,bufkey :: !BufferRef -- ^ the buffer this window opens to+ ,tospnt :: !Int -- ^ the buffer point of the top of screen+ ,bospnt :: !Int -- ^ the buffer point of the bottom of screen+ ,height :: !Int -- ^ height of the window (in number of lines displayed)+ }+-- | Get the identification of a window.+winkey :: Window -> (Bool, BufferRef)+winkey w = (isMini w, bufkey w)++instance Show Window where+ show w = "Window to " ++ show (bufkey w) ++ "{" ++ show (height w) ++ "}"++pointInWindow :: Point -> Window -> Bool+pointInWindow point win = tospnt win <= point && point <= bospnt win++-- | Return a "fake" window onto a buffer.+dummyWindow :: BufferRef -> Window+dummyWindow b = Window False b 0 0 0
+ Yi/WindowSet.hs view
@@ -0,0 +1,88 @@+--+-- Copyright (c) 2007 Jean-Philippe Bernardy+--+--++module Yi.WindowSet where+-- FIXME: export abstractly++import Prelude hiding (elem, error)++import Yi.Debug+import Control.Monad.Trans+import Data.Foldable+import Data.Traversable+import Data.Monoid+import Control.Applicative+import Yi.Accessor++data WindowSet a = WindowSet { before::[a], current::a, after :: [a] }+ deriving (Show)++instance Foldable WindowSet where+ foldMap f (WindowSet b c a) = getDual (foldMap (Dual . f) b) `mappend` (f c) `mappend` foldMap f a++instance Functor WindowSet where+ fmap f (WindowSet b c a) = WindowSet (fmap f b) (f c) (fmap f a)++instance Traversable WindowSet where+ traverse f (WindowSet b c a) = WindowSet <$> traverse f (reverse b) <*> f c <*> traverse f a++currentA :: Accessor (WindowSet a) a+currentA = Accessor current modifyCurrent+ where modifyCurrent :: (a -> a) -> WindowSet a -> WindowSet a+ modifyCurrent f (WindowSet b c a) = WindowSet b (f c) a+++new :: a -> WindowSet a+new w = WindowSet [] w []++-- | Add a window, focus it.+add :: a -> WindowSet a -> WindowSet a+add w (WindowSet b c a) = WindowSet (c:b) w a++next :: WindowSet a -> a+next = current . forward++-- | Delete a window+delete :: WindowSet a -> WindowSet a+delete (WindowSet [] c []) = WindowSet [] c [] -- never delete the last window+delete (WindowSet (b:bs) _ a) = WindowSet bs b a+delete (WindowSet [] _ (a:as)) = WindowSet [] a as++-- property: delete (add w) ws == ws++size :: WindowSet a -> Int+size (WindowSet as _ bs) = length as + 1 + length bs++deleteOthers :: WindowSet a -> WindowSet a+deleteOthers (WindowSet _ c _) = WindowSet [] c []++forward :: WindowSet a -> WindowSet a+forward (WindowSet [] c []) = WindowSet [] c []+forward (WindowSet b c (a:as)) = WindowSet (c:b) a as+forward (WindowSet b c []) = WindowSet [] (last b) ((reverse (init b)) ++ [c])++backward :: WindowSet a -> WindowSet a+backward (WindowSet [] c []) = WindowSet [] c []+backward (WindowSet (b:bs) c a) = WindowSet bs b (c:a)+backward (WindowSet [] c a) = WindowSet (c:reverse (init a)) (last a) []++setFocus :: (Show a, Eq a) => a -> WindowSet a -> WindowSet a+setFocus w ws@(WindowSet b c a) + | c == w = ws+ | w `elem` a = setFocus w (forward ws)+ | w `elem` b = setFocus w (backward ws)+ | otherwise = error $ "Lost window: " ++ show w ++ " among " ++ show ws++withFocus :: WindowSet a -> WindowSet (a, Bool)+withFocus (WindowSet b c a) = WindowSet (zip b (repeat False)) (c, True) (zip a (repeat False))++focusIndex :: Int -> WindowSet a -> WindowSet a+focusIndex n ws = WindowSet (reverse b) c a+ where (b,c:a) = splitAt n $ toList ws++debug :: (Show a, MonadIO m) => String -> WindowSet a -> m ()+debug msg (WindowSet b c a) = logPutStrLn $ msg ++ ": " ++ show b ++ show c ++ show a++
+ Yi/Yi.hs view
@@ -0,0 +1,55 @@+--+-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons+--+--++--+-- Front end to the library, for use by external scripts. Just reexports+-- a bunch of modules.+--+-- You should therefore:+-- import Yi.Yi+-- in your ~/.yi/ scripts+--++module Yi.Yi (+ -- all things re-exported here are made available to keymaps definitions.++ module Control.Monad, -- since all actions are monadic, this is very useful to combine them.+ module Control.Applicative, -- same reasoning+ module Yi.Buffer,+ module Yi.Buffer.HighLevel,+ module Yi.Buffer.Normal,+ module Yi.Core,+ module Yi.Debug,+ module Yi.Dired,+ module Yi.Editor,+ module Yi.Eval,+ module Yi.Event, -- hack, for key defns+ module Yi.File,+ module Yi.Interact,+ module Yi.Buffer.Region,+ module Yi.Search,+ module Yi.Style+ ) where+import Control.Monad+import Control.Applicative+import Yi.Buffer+import Yi.Buffer.HighLevel+import Yi.Buffer.Normal+import Yi.Core+import Yi.Debug+import Yi.Dired+import Yi.Editor+import Yi.Eval+import Yi.Event -- so we can see key defns+import Yi.File+import Yi.Interact hiding (write)+import Yi.Buffer.Region+import Yi.Search+import Yi.Style+++++
+ art/yi+lambda-fat.pdf view
binary file changed (absent → 6346 bytes)
+ examples/YiConfig.hs view
@@ -0,0 +1,19 @@+-- This is jyp's YiConfig.++-- Don't run with --as=..., that will overwrite the keymap set here.++module YiConfig (yiMain) where++import Yi.Yi +import Yi.Editor+import Yi.Keymap.Emacs+-- import Yi.Keymap.Vim+import Control.Monad.Trans+import Yi.Buffer++yiMain :: YiM ()+yiMain = do+ -- I prefer to use Emacs keymap+ changeKeymap keymap+ msgEditor "User configuration successful."+
yi.cabal view
@@ -1,25 +1,121 @@ name: yi-version: 0.2+version: 0.3 category: Editor synopsis: The Haskell-Scriptable Editor description: Yi is a text editor written and extensible in Haskell. The goal of Yi is- to provide a flexible, powerful and correct editor core dynamically+ to provide a flexible, powerful, and correct editor core which is dynamically scriptable in Haskell.- Note that you will need either yi-gtk or yi-vty to actually run Yi. license: GPL license-file: LICENSE-author: Don Stewart-maintainer: dons@cse.unsw.edu.au-build-depends: ghc>=6.6, base, mtl, regex-posix+author: AUTHORS+maintainer: yi-devel@googlegroups.com+homepage: http://haskell.org/haskellwiki/Yi -executable: yi-main-is: Main.hs-other-modules: - Yi.Boot- Yi.Debug- Yi.Kernel-extensions: CPP-ghc-options: -Wall -fglasgow-exts -O -funbox-strict-fields -fasm -optl-Wl,-s+cabal-Version: >= 1.2+tested-with: GHC==6.8.2+build-type: Custom+data-files:+ examples/YiConfig.hs+ art/yi+lambda-fat.pdf+ -- FIXME: Install Cocoa icon only when Cocoa configured +flag dynamic+ Description: enable Yi dynamic features+ Default: True+ -- disabling this is experimental and for testing purposes only+ -- DO NOT write code that depends on this++flag vty+ Description: Provide Vty UI++flag gtk+ Description: Provide GTK UI++-- Cocoa UI is experimental (and at the moment probably even broken)+-- It seems that it suffers from bugs in HOC+flag cocoa+ Description: Provide experimental Cocoa UI+ Default: False+++-- library+-- exposed-modules:+-- Yi.Accessor, Yi.Buffer, Yi.Buffer.HighLevel, Yi.Buffer.Implementation,+-- Yi.Buffer.Normal, Yi.Buffer.Region, Yi.Char, Yi.Completion, Yi.Core,+-- Yi.Debug, Yi.Dired, Yi.Dynamic, Yi.Editor, Yi.Eval, Yi.Event, Yi.FingerString, Yi.History,+-- Yi.Indent, Yi.Interact, Yi.Kernel, Yi.Keymap, Yi.Keymap.Completion, Yi.Keymap.Emacs,+-- Yi.Keymap.Emacs.Keys, Yi.Keymap.Emacs.KillRing, Yi.Keymap.Emacs.UnivArgument,+-- Yi.Keymap.Emacs.Utils, Yi.Keymap.Normal, Yi.Keymap.Vim, Yi.Main, Yi.MkTemp, Yi.Monad, Yi.Process,+-- Yi.Search, Yi.String, Yi.Style, Yi.Syntax, Yi.Syntax.Table, Yi.Templates, Yi.TextCompletion,+-- Yi.UI.Common, Yi.UI.Gtk, Yi.UI.Vty, Yi.Undo, Yi.Vty, Yi.Window, Yi.WindowSet, Yi.Yi, Yi.Syntax.Cplusplus,+-- Yi.Syntax.Haskell, Yi.Syntax.Latex, Yi.Syntax.Srmc, Yi.Syntax.Cabal+-- -- Broken:+-- -- Yi.Keymap.Ee,+-- -- Yi.Keymap.Gwern,+-- -- Yi.Keymap.Joe,+-- -- Yi.Keymap.Mg,+-- -- Yi.Keymap.Nano,+-- -- Yi.Keymap.Vi,+-- -- Broken?+-- -- Yi.UI.Cocoa+-- -- We can specify the two UIs (VTY and GTK) - which forces them to be built -+-- -- because they are set to build by default (True) anyway.+--+-- include-dirs: Yi/Syntax+-- -- for alex.hsinc+--+++--+-- extensions: CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,+-- ForeignFunctionInterface, FunctionalDependencies, GADTs,+-- GeneralizedNewtypeDeriving, MagicHash, MultiParamTypeClasses,+-- ParallelListComp, PatternGuards, PatternSignatures, Rank2Types,+-- ScopedTypeVariables TypeSynonymInstances, UndecidableInstances++executable yi+ build-depends: array, base, containers, directory, filepath>=1.0,+ mtl, process, old-locale, old-time, unix, random+-- unix dependency should be eventually removed++ build-tools: alex >= 2.0.1 && < 3+ -- haddock >= 2.0, + -- it seems harsh to require haddock 2.0 to even configure Yi;+ -- and there is a message about haddock 2 in Setup.hs+ build-depends: bytestring ==0.9.0.1 + -- >= 0.9 && < 0.9.0.4 + build-depends: fingertree++ build-depends: regex-base ==0.72.0.1+ build-depends: regex-compat ==0.71.0.1+ build-depends: regex-posix ==0.72.0.2++ ghc-options: -Wall -optl-Wl,-s+-- ghc-options later on get appended to the original++ if flag (dynamic)+ build-depends: ghc>=6.8.2+ ghc-options: -DDYNAMIC++ if flag (vty)+ build-depends: vty>=3.0.0+ ghc-options: -DFRONTEND_VTY++ if flag (gtk)+ build-depends: gtk>=0.9.12+ ghc-options: -DFRONTEND_GTK++ if flag (cocoa)+ build-depends: HOC, HOC-AppKit, HOC-Foundation+ ghc-options: -DFRONTEND_COCOA++ if !(flag(vty) || flag (gtk) || flag(cocoa))+ buildable: False++ main-is: Main.hs+ other-modules: Yi.Syntax.Cplusplus, Yi.Syntax.Haskell, Yi.Syntax.LiterateHaskell,+ Yi.Syntax.Latex, Yi.Syntax.Srmc, Yi.Syntax.Cabal+ include-dirs: Yi/Syntax+ extensions: CPP