yi 0.5.0.1 → 0.5.2
raw patch · 81 files changed
+3190/−1727 lines, 81 filesdep ~Cabaldep ~basedep ~ghc
Dependency ranges changed: Cabal, base, ghc, ghc-paths, regex-base, regex-tdfa
Files
- Data/ByteRope.hs +2/−2
- Data/Prototype.hs +3/−0
- Data/Trie.hs +62/−0
- HConf.hs +4/−1
- Shim/CabalInfo.hs +29/−6
- Shim/ExprSearch.hs +28/−1
- Shim/GhcCompat.hs +98/−6
- Shim/Hsinfo.hs +67/−43
- Shim/ProjectContent.hs +192/−193
- Shim/SHM.hs +10/−2
- Shim/SessionMonad.hs +6/−1
- Shim/Utils.hs +1/−1
- Yi.hs +1/−1
- Yi/Buffer/Basic.hs +3/−9
- Yi/Buffer/HighLevel.hs +73/−63
- Yi/Buffer/Implementation.hs +16/−83
- Yi/Buffer/Indent.hs +25/−42
- Yi/Buffer/Misc.hs +191/−88
- Yi/Buffer/Normal.hs +61/−10
- Yi/Buffer/Region.hs +24/−15
- Yi/Buffer/Undo.hs +24/−16
- Yi/Completion.hs +1/−0
- Yi/Core.hs +12/−14
- Yi/Editor.hs +84/−22
- Yi/Eval.hs +5/−1
- Yi/Event.hs +1/−1
- Yi/File.hs +24/−2
- Yi/History.hs +1/−1
- Yi/IReader.hs +100/−0
- Yi/IncrementalParse.hs +166/−223
- Yi/Interpreter.hs +4/−3
- Yi/Keymap.hs +0/−3
- Yi/Keymap/Cua.hs +65/−30
- Yi/Keymap/Emacs.hs +8/−6
- Yi/Keymap/Emacs/KillRing.hs +2/−2
- Yi/Keymap/Emacs/Utils.hs +75/−10
- Yi/Keymap/Keys.hs +5/−2
- Yi/Keymap/Vim.hs +220/−167
- Yi/Lexer/Alex.hs +2/−1
- Yi/Lexer/GNUMake.x +63/−0
- Yi/Lexer/Haskell.x +28/−28
- Yi/Lexer/LiterateHaskell.x +86/−66
- Yi/Lexer/Ott.x +112/−0
- Yi/Lexer/Python.x +2/−2
- Yi/Main.hs +23/−10
- Yi/MiniBuffer.hs +10/−4
- Yi/Misc.hs +1/−5
- Yi/MkTemp.hs +1/−1
- Yi/Mode/Haskell.hs +50/−37
- Yi/Mode/IReader.hs +26/−0
- Yi/Mode/Interactive.hs +35/−28
- Yi/Mode/Latex.hs +41/−0
- Yi/Modes.hs +36/−34
- Yi/Rectangle.hs +2/−0
- Yi/Regex.hs +33/−3
- Yi/Region.hs +10/−0
- Yi/Search.hs +44/−44
- Yi/Style.hs +20/−8
- Yi/Style/Library.hs +18/−7
- Yi/Syntax.hs +14/−4
- Yi/Syntax/Haskell.hs +2/−1
- Yi/Syntax/Latex.hs +9/−6
- Yi/Syntax/Linear.hs +1/−0
- Yi/Syntax/OnlineTree.hs +70/−0
- Yi/Syntax/Paren.hs +1/−1
- Yi/Tag.hs +76/−0
- Yi/TextCompletion.hs +3/−3
- Yi/UI/Cocoa.hs +108/−49
- Yi/UI/Cocoa/Application.hs +60/−8
- Yi/UI/Cocoa/TextStorage.hs +221/−95
- Yi/UI/Cocoa/TextView.hs +114/−11
- Yi/UI/Cocoa/Utils.hs +29/−10
- Yi/UI/Gtk.hs +9/−7
- Yi/UI/Gtk/ProjectTree.hs +1/−9
- Yi/UI/Gtk/Utils.hs +17/−17
- Yi/UI/Pango.hs +25/−22
- Yi/UI/TabBar.hs +5/−17
- Yi/UI/Utils.hs +7/−1
- Yi/UI/Vty.hs +58/−98
- tests/TestSuite.hs +2/−3
- yi.cabal +22/−17
Data/ByteRope.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- Consider splitting off as a separate package -- Copyright (c) 2008 Gustav Munkby @@ -55,7 +55,7 @@ t |- b | B.null b = t | otherwise = t |> b -instance Measured Size ByteString where+instance Measured (Sum Int) ByteString where measure = Sum . B.length toLazyByteString :: ByteRope -> LB.ByteString
Data/Prototype.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types #-} -- | Support for OO-like prototypes. module Data.Prototype where @@ -21,6 +22,7 @@ -- | Get the value of a prototype. -- This can return bottom in case some fields are recursively defined in terms of each other.+extractValue :: Proto t -> t extractValue (Proto o) = fix o -- | Override a prototype. Fields can be defined in terms of their definition in the base prototype.@@ -38,6 +40,7 @@ in extension super self) -- | Field access+(.->) :: forall t a. Proto t -> (t -> a) -> a p .-> f = f (extractValue p)
+ Data/Trie.hs view
@@ -0,0 +1,62 @@+module Data.Trie where++-- Trie module. Partly taken from http://www.haskell.org/haskellwiki/Haskell_Quiz/Word_Search/Solution_Sjanssen++import qualified Data.Map as Map+import Control.Monad++data Trie = Trie Bool (Map.Map Char Trie) deriving (Show)++-- | A blank Trie+empty :: Trie+empty = Trie False Map.empty++-- | Insert a new string into the trie.+insert :: String -> Trie -> Trie+insert [] (Trie _ m) = Trie True m+insert (x:xs) (Trie b m) = Trie b $ Map.alter (maybe (Just $ fromString xs) (Just . insert xs)) x m++fromString :: String -> Trie+fromString = foldr (\x xs -> Trie False (Map.singleton x xs)) (Trie True Map.empty)++-- | Take a list of String and compress it into a Trie+fromList :: [String] -> Trie+fromList = foldr insert empty++-- | Take a trie and expand it into the strings that it represents+toList :: Trie -> [String]+toList (Trie b m) =+ if b then "":expand+ else expand+ where expand = [ char:word | (char, trie) <- Map.toList m,+ word <- toList trie ]++-- | Takes a trie and a prefix and returns the sub-trie that+-- of words with that prefix+lookupPrefix :: (MonadPlus m) => String -> Trie -> m Trie+lookupPrefix [] trie = return trie+lookupPrefix (x:xs) (Trie _ m) = liftMaybe (Map.lookup x m) >>= lookupPrefix xs++liftMaybe :: MonadPlus m => Maybe a -> m a+liftMaybe Nothing = mzero+liftMaybe (Just x) = return x++-- | Finds the longest certain path down the trie starting at a the root+-- Invariant Assumption: All paths have at least one 'true' node below them+forcedNext :: Trie -> String+forcedNext (Trie _ m) =+ if length ls == 1 then+ let (char, trie) = head ls in+ char:forcedNext trie+ else []+ where ls = Map.toList m++-- | Helper function, finds all the suffixes of a given prefix+possibleSuffixes :: String -> Trie -> [String]+possibleSuffixes prefix fulltrie =+ lookupPrefix prefix fulltrie >>= toList++-- | Helper function, finds the longest certain path down the trie starting at a given word+certainSuffix :: String -> Trie -> String+certainSuffix prefix fulltrie =+ lookupPrefix prefix fulltrie >>= forcedNext
HConf.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module HConf (getHConf, HConf(HConf), hconfOptions) where import Prelude hiding ( catch )@@ -24,6 +25,7 @@ import System.Environment import System.Console.GetOpt import System.FilePath ((</>), takeDirectory)+import qualified GHC.Paths {- @@ -188,8 +190,9 @@ status <- bracket (openFile err WriteMode) hClose $ \h -> do -- note that since we checked for recompilation ourselves, -- we disable ghc recompilaton checks.- waitForProcess =<< runProcess "ghc" ["--make", projectName ++ ".hs", "-i", "-fforce-recomp", "-v0", "-o",binn,"-threaded"] (Just dir)+ waitForProcess =<< runProcess GHC.Paths.ghc ["--make", projectName ++ ".hs", "-i", "-fforce-recomp", "-v0", "-o",binn,"-threaded"] (Just dir) Nothing Nothing Nothing (Just h)+ -- note that we use the ghc executable used to build Yi (through GHC.Paths). -- now, if it fails, run xmessage to let the user know: if status /= ExitSuccess
Shim/CabalInfo.hs view
@@ -3,16 +3,17 @@ import Shim.Utils import qualified Control.Exception as CE-import System.FilePath ( takeDirectory, (</>), (<.>), dropFileName, equalFilePath )+import System.FilePath import Control.Monad.State import Data.Maybe import Control.Applicative-import Distribution.Simple.Utils+import Distribution.Simple.Utils hiding (findPackageDesc)+import Distribution.ModuleName import Distribution.PackageDescription import qualified Distribution.PackageDescription as Library (Library(..)) import qualified Distribution.PackageDescription as BuildInfo (BuildInfo(..))-import System.Directory (canonicalizePath)+import System.Directory guessCabalFile :: String -> IO (Maybe FilePath) guessCabalFile sourcefile = do@@ -22,8 +23,8 @@ logS $ "looking in: " ++ dir pdfile <- CE.try (findPackageDesc dir) case pdfile of- Right f -> return . Just $ dir </> f- Left _ -> return Nothing+ Right (Just f) -> return . Just $ dir </> f+ _ -> return Nothing -- | Guess what lib/exe the sourcefile belongs to. guessCabalStanza :: FilePath -> FilePath -> PackageDescription -> IO (Maybe String, BuildInfo)@@ -36,8 +37,30 @@ | Just lib <- [library pkg_descr] ] ++ [ (Just (exeName exe), [modulePath exe], buildInfo exe) | exe <- executables pkg_descr ]- moduleFiles mod = [dotToSep mod <.> ext | ext <- ["hs", "lhs"] ]+ moduleFiles mod = [toFilePath mod <.> ext | ext <- ["hs", "lhs"] ] allStanzas' = [(name, [projpath </> dir </> file | dir <- hsSourceDirs bi, file <- files ++ concatMap moduleFiles (BuildInfo.otherModules bi)], bi) | (name, files, bi) <- allStanzas, buildable bi] eqPath p1 p2 = equalFilePath <$> canonicalizePath p1 <*> canonicalizePath p2 matchingStanza (_,files,_) = or <$> mapM (eqPath sourcefile) files+++-- Taken from Cabal and modified so that nothing is printed to stdout.+-- TODO: Perhaps export something better from Cabal++-- |Find a package description file in the given directory. Looks for+-- @.cabal@ files.+findPackageDesc :: FilePath -- ^Where to look+ -> IO (Maybe FilePath) -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+ -- file we filter to exclude dirs and null base file names:+ cabalFiles <- filterM doesFileExist+ [ dir </> file+ | file <- files+ , let (name, ext) = splitExtension file+ , not (null name) && ext == ".cabal" ]+ case cabalFiles of+ [] -> return Nothing+ [cabalFile] -> return (Just cabalFile)+ multiple -> return Nothing
Shim/ExprSearch.hs view
@@ -40,11 +40,20 @@ | FoundModule ModuleName | NotFound +#if __GLASGOW_HASKELL__ < 610 findExprInCheckedModule :: Int -> Int -> CheckedModule -> FindResult findExprInCheckedModule line col (CheckedModule { parsedSource = hsSource, renamedSource = mb_rnSource, typecheckedSource = mb_tcSource }) =+#else+findExprInCheckedModule :: Int -> Int -> TypecheckedModule -> FindResult+findExprInCheckedModule line col mdl =+ let hsSource = parsedSource mdl+ mb_rnSource = renamedSource mdl+ mb_tcSource = Just $ typecheckedSource mdl+ in+#endif case doSearch searchLBinds FoundId mb_tcSource of NotFound -> case doSearch searchRenamedSource FoundName mb_rnSource of NotFound -> doSearchModule hsSource@@ -131,11 +140,21 @@ searchLPat (L span (VarPat id)) = checkId span id searchLPat (L span (LitPat lit)) = checkLiteral span lit+#if __GLASGOW_HASKELL__ >= 610+searchLPat (L span (NPat lit _ _)) = checkLiteral span (over_lit_lit lit)+#else searchLPat (L span (NPat lit _ _ _)) = checkLiteral span (over_lit_lit lit)+#endif where over_lit_lit :: HsOverLit id -> HsLit- over_lit_lit (HsIntegral i _) = HsIntPrim i+#if __GLASGOW_HASKELL__ >= 610+ over_lit_lit (OverLit (HsIntegral i) _ _ _) = HsIntPrim i+ over_lit_lit (OverLit (HsFractional f) _ _ _) = HsFloatPrim f+ over_lit_lit (OverLit (HsIsString s) _ _ _) = HsStringPrim s+#else+ over_lit_lit (HsIntegral i _) = HsIntPrim i over_lit_lit (HsFractional f _) = HsFloatPrim f+#endif searchLPat lpat = lsearch searchPat lpat searchPat pat = @@ -499,7 +518,9 @@ -- ---------------------------------------------------------------------------- -- DeprecDecl +#if __GLASGOW_HASKELL__ < 610 searchLDeprecDecl (L span (Deprecation id _)) = checkId span id+#endif -- ---------------------------------------------------------------------------- -- Group@@ -511,7 +532,9 @@ searchList searchLFixitySig (hs_fixds g) `orSearch` searchList searchLDefaultDecl (hs_defds g) `orSearch` searchList searchLForeignDecl (hs_fords g) `orSearch`+#if __GLASGOW_HASKELL__ < 610 searchList searchLDeprecDecl (hs_depds g) `orSearch`+#endif searchList searchLRuleDecl (hs_ruleds g) -- ----------------------------------------------------------------------------@@ -519,7 +542,11 @@ searchLImportDecl ldecl = lsearch searchImportDecl ldecl +#if __GLASGOW_HASKELL__ >= 610+searchImportDecl (ImportDecl (L span modl) _ _ _ _ _) = inSpan span (Search $ \_ _ _ _ -> FoundModule modl)+#else searchImportDecl (ImportDecl (L span modl) _ _ _ _) = inSpan span (Search $ \_ _ _ _ -> FoundModule modl)+#endif -- ---------------------------------------------------------------------------- -- Utils
Shim/GhcCompat.hs view
@@ -1,17 +1,55 @@ {-# OPTIONS_GHC -cpp #-}-module Shim.GhcCompat where+module Shim.GhcCompat+ ( load+ , getModuleGraph+ , getSessionDynFlags+ , getRdrNamesInScope+ , findModule+ , exprType+ , getPrintUnqual+ , compileExpr+ , setSessionDynFlags+ , setTargets+ , setContext+ , getModuleInfo+ , lookupName+ , newSession+ , getContext+ , modInfoLookupName+ , checkModule+ , parseDynamicFlags+ , workingDirectoryChanged+ , getNamesInScope+ ) where +#if __GLASGOW_HASKELL__ >= 610+import GHC hiding ( load, getModuleGraph, getSessionDynFlags, getRdrNamesInScope,+ findModule, exprType, getPrintUnqual, compileExpr, setSessionDynFlags,+ setTargets, setContext, load, getModuleInfo, lookupName, getContext,+ modInfoLookupName, parseDynamicFlags, workingDirectoryChanged,+ getNamesInScope)+#else+import GHC hiding ( load, newSession, parseDynamicFlags )+#endif -import GHC hiding ( load, newSession )-import qualified GHC+import qualified GHC as GHC import StaticFlags import Panic+import HscTypes++-- FIX: we should check for Cabal version instead+#if __GLASGOW_HASKELL__ >= 610+import qualified Distribution.PackageDescription.Parse as DP+#else import qualified Distribution.PackageDescription as DP+#endif+ import Distribution.Verbosity import Control.Concurrent.MVar ( tryTakeMVar, modifyMVar_, newMVar, readMVar, putMVar )-import Data.List ( nub )+import Data.List ( nub, find ) import System.IO.Unsafe ( unsafePerformIO )+import Data.IORef #if __GLASGOW_HASKELL__ == 606@@ -44,15 +82,69 @@ {-# NOINLINE haveNewSessionBug #-} haveNewSessionBug = unsafePerformIO (newMVar False) -#else+#elif __GLASGOW_HASKELL__ == 608 -- Hack to get parseStaticFlags called only once-initGhc = unsafePerformIO$ StaticFlags.parseStaticFlags [] +initGhc = unsafePerformIO$ parseStaticFlags [] newSession :: Maybe FilePath -> IO Session newSession fp = initGhc `seq` GHC.newSession fp +-- >= 6.10+#else++newSession :: Maybe FilePath -> IO Session+newSession fp = runGhc fp getRealSession+++getRealSession :: Ghc Session+getRealSession = do+ hscEnv <- getSession+ warns <- getWarnings+ ref1 <- liftIO $ newIORef hscEnv+ ref2 <- liftIO $ newIORef warns+ return $ Session ref1 ref2 + #endif readPackageDescription = DP.readPackageDescription silent +#if __GLASGOW_HASKELL__ < 610+type TypecheckedModule = CheckedModule+parseDynamicFlags ses a b = GHC.parseDynamicFlags a b+#endif++#if __GLASGOW_HASKELL__ >= 610+getModuleGraph session = reflectGhc GHC.getModuleGraph session+getSessionDynFlags session = reflectGhc GHC.getSessionDynFlags session+setSessionDynFlags session f = reflectGhc (GHC.setSessionDynFlags f) session+findModule session a b = reflectGhc (GHC.findModule a b) session+getRdrNamesInScope session = reflectGhc GHC.getRdrNamesInScope session++-- FIX: we should catch the exception+exprType session e = fmap Just $ reflectGhc (GHC.exprType e) session++getPrintUnqual session = reflectGhc GHC.getPrintUnqual session++-- FIX: we should catch the exception+compileExpr session e = fmap Just $ reflectGhc (GHC.compileExpr e) session++setTargets session ts = reflectGhc (GHC.setTargets ts) session+setContext session a b = reflectGhc (GHC.setContext a b) session+load session a = reflectGhc (GHC.load a) session+getModuleInfo session a = reflectGhc (GHC.getModuleInfo a) session+lookupName session a = reflectGhc (GHC.lookupName a) session+modInfoLookupName session a b = reflectGhc (GHC.modInfoLookupName a b) session+parseDynamicFlags session a b = fmap (\(a,b,_) -> (a,b)) $ reflectGhc (GHC.parseDynamicFlags a (map noLoc b)) session+getContext session = reflectGhc GHC.getContext session+workingDirectoryChanged session = reflectGhc GHC.workingDirectoryChanged session+getNamesInScope session = reflectGhc GHC.getNamesInScope session++checkModule :: Session -> ModuleName -> Bool -> IO (Maybe TypecheckedModule)+checkModule session modname _ = do+ graph <- getModuleGraph session+ let res = find ((modname ==) . moduleName . ms_mod) graph+ case res of+ Just modsum -> fmap Just $ reflectGhc (typecheckModule =<< parseModule modsum) session+ Nothing -> return Nothing +#endif
Shim/Hsinfo.hs view
@@ -11,7 +11,7 @@ import Shim.Utils import Shim.ExprSearch import Shim.SessionMonad-import Shim.GhcCompat+import qualified Shim.GhcCompat as GhcCompat import Shim.CabalInfo import Control.Applicative@@ -29,30 +29,38 @@ import qualified Data.Digest.Pure.MD5 as MD5 import qualified GHC++#if __GLASGOW_HASKELL__ >= 610+import GHC hiding ( load, getSession, getModuleGraph, getSessionDynFlags, + findModule, getRdrNamesInScope, compileExpr, exprType,+ getPrintUnqual, setSessionDynFlags )+#else import GHC hiding ( load, newSession, (<.>) )+#endif+ import Outputable import Panic import UniqFM ( eltsUFM ) import Packages ( pkgIdMap, exposed, exposedModules ) import Id import Name+#if __GLASGOW_HASKELL__ >= 610+import HscTypes hiding ( getSession ) +#else import HscTypes+#endif import SrcLoc import PprTyThing import StringBuffer ( stringToStringBuffer, StringBuffer ) import HeaderInfo ( getOptions ) import DriverPhases ( Phase(..), startPhase ) import Yi.Debug (logPutStrLn)-import Distribution.Simple.Utils(dotToSep) import Distribution.Text import Distribution.Simple ( pkgName ) import Distribution.Compiler ( CompilerFlavor (..) )-import Distribution.Simple.Compiler ( extensionsToFlags ) import Distribution.Simple.GHC-import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Configure import Distribution.Verbosity-import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription ( buildDepends, PackageDescription, BuildInfo, library, executables, hsSourceDirs, extensions, includeDirs, extraLibs,@@ -71,11 +79,11 @@ ghcInit :: IO Session ghcInit = do #if __GLASGOW_HASKELL__ == 606- ses <- newSession JustTypecheck (Just ghclibdir)+ ses <- GhcCompat.newSession JustTypecheck (Just ghclibdir) #else- ses <- newSession (Just ghclibdir)+ ses <- GhcCompat.newSession (Just ghclibdir) #endif- dflags0 <- GHC.getSessionDynFlags ses+ dflags0 <- GhcCompat.getSessionDynFlags ses let ignore _ _ _ _ = return () dflags1 = dflags0{ hscTarget = HscNothing, verbosity = 1,@@ -83,7 +91,7 @@ ghcLink = NoLink, #endif log_action = ignore}- GHC.setSessionDynFlags ses dflags1+ GhcCompat.setSessionDynFlags ses dflags1 return ses ghclibdir = GHC.Paths.libdir@@ -123,22 +131,22 @@ io $ setCurrentDirectory projectroot newDir <- io $ getCurrentDirectory when (newDir /= oldDir) $- io $ workingDirectoryChanged ses+ io $ GhcCompat.workingDirectoryChanged ses findModuleInFile :: Session -> FilePath -> IO Module findModuleInFile ses sourcefile = do- l <- GHC.getModuleGraph ses+ l <- GhcCompat.getModuleGraph ses let modq = ms_mod $ fromMaybe (error "findModuleInFile") $ find (\ms -> msHsFilePath ms == sourcefile) l return modq idsInScope :: Session -> SHM [String] idsInScope ses = do- rdrs <- io $ GHC.getRdrNamesInScope ses+ rdrs <- io $ GhcCompat.getRdrNamesInScope ses return $ map (showSDoc.ppr) rdrs getPrelude :: Session -> IO Module-getPrelude ses = GHC.findModule ses prel_name Nothing+getPrelude ses = GhcCompat.findModule ses prel_name Nothing where prel_name = GHC.mkModuleName "Prelude" pprIdent :: Id -> String@@ -154,9 +162,13 @@ bufferNeedsPreprocessing sourcefile source = do sourcebuf <- io $ stringToStringBuffer source ses <- getSessionFor sourcefile- dflags <- io $ getSessionDynFlags ses+ dflags <- io $ GhcCompat.getSessionDynFlags ses+#if __GLASGOW_HASKELL__ >= 610+ let local_opts = map unLoc (getOptions dflags sourcebuf sourcefile)+#else let local_opts = map unLoc (getOptions sourcebuf sourcefile)- (dflags', _) <- io $ parseDynamicFlags dflags local_opts+#endif+ (dflags', _) <- io $ GhcCompat.parseDynamicFlags ses dflags local_opts let src_ext = takeExtension sourcefile needs_preprocessing | Unlit _ <- startPhase src_ext = True@@ -205,9 +217,9 @@ id_data <- io$ getIdData ses m <- io $ findModuleInFile ses sourcefile #if __GLASGOW_HASKELL__ > 606- cm0 <- io $ checkModule ses (moduleName m) False+ cm0 <- io $ GhcCompat.checkModule ses (moduleName m) False #else- cm0 <- io $ checkModule ses $ moduleName m+ cm0 <- io $ GhcCompat.checkModule ses $ moduleName m #endif h <- io $ hashSource sourcefile source let cm = do {c <- cm0; return (h, c)}@@ -217,19 +229,23 @@ load' sourcefile source = do source' <- addTime source ses <- getSessionFor sourcefile- dflags0 <- io $ GHC.getSessionDynFlags ses+ dflags0 <- io $ GhcCompat.getSessionDynFlags ses logAction <- getCompLogAction let dflags1 = dflags0{ log_action = logAction, flags = Opt_ForceRecomp : flags dflags0 }- io $ GHC.setSessionDynFlags ses dflags1- io $ GHC.setTargets ses [Target (TargetFile sourcefile Nothing) source']- loadResult <- io $ GHC.load ses LoadAllTargets+ io $ GhcCompat.setSessionDynFlags ses dflags1+#if __GLASGOW_HASKELL__ >= 610+ io $ GhcCompat.setTargets ses [Target (TargetFile sourcefile Nothing) False source']+#else+ io $ GhcCompat.setTargets ses [Target (TargetFile sourcefile Nothing) source']+#endif+ loadResult <- io $ GhcCompat.load ses LoadAllTargets case loadResult of Succeeded -> do -- GHC takes care of setting the right context modq <- io $ findModuleInFile ses sourcefile- io $ GHC.setContext ses [modq] []+ io $ GhcCompat.setContext ses [modq] [] return (Succeeded,ses) Failed -> do -- We take care of getting at least the Prelude- io(GHC.setContext ses [] =<< liftM (:[]) (getPrelude ses))+ io(GhcCompat.setContext ses [] =<< liftM (:[]) (getPrelude ses)) return (Failed,ses) addTime :: Maybe String -> SHM (Maybe (StringBuffer, ClockTime))@@ -252,7 +268,7 @@ ghcSetDir $ dropFileName sourcefile return ses -checkModuleCached :: FilePath -> Maybe String -> SHM (CheckedModule, Session)+checkModuleCached :: FilePath -> Maybe String -> SHM (TypecheckedModule, Session) checkModuleCached sourcefile source = do l0 <- M.lookup sourcefile `liftM` getCompBuffer hash <- io $ hashSource sourcefile source@@ -277,10 +293,10 @@ return ses logInfo $ concat ["Using options ", unSplit ',' opts, " and cabal file ", cabalfile]- dflags0 <- io $ GHC.getSessionDynFlags ses+ dflags0 <- io $ GhcCompat.getSessionDynFlags ses ghcSetDir $ dropFileName cabalfile- (dflags1, _) <- io $ GHC.parseDynamicFlags dflags0 opts- io $ GHC.setSessionDynFlags ses dflags1+ (dflags1, _) <- io $ GhcCompat.parseDynamicFlags ses dflags0 opts+ io $ GhcCompat.setSessionDynFlags ses dflags1 return ses storeFileInfo :: FilePath -> CompilationResult -> Maybe CachedMod -> IdData -> SHM ()@@ -289,7 +305,7 @@ getIdData :: Session -> IO IdData getIdData ses = do- things <- getNamesInScope ses >>= mapM (lookupName ses)+ things <- GhcCompat.getNamesInScope ses >>= mapM (GhcCompat.lookupName ses) return [(s $ nameOccName $ idName ident, s $ idType ident) | Just(AnId ident) <- things] where s x = showSDocUnqual $ ppr x@@ -301,14 +317,18 @@ findModulesPrefix :: FilePath -> String -> SHM [String] findModulesPrefix sourcefile pref = do ses <- getSessionFor sourcefile- dflags <- io $ GHC.getSessionDynFlags ses+ dflags <- io $ GhcCompat.getSessionDynFlags ses let pkg_mods = allExposedModules dflags return $ filter (pref `isPrefixOf`) (map (showSDoc.ppr) pkg_mods) allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags =+#if __GLASGOW_HASKELL__ >= 610+ concatMap Packages.exposedModules (filter exposed (eltsUFM pkg_db))+#else map GHC.mkModuleName (concatMap Packages.exposedModules (filter exposed (eltsUFM pkg_db)))+#endif where pkg_db = pkgIdMap (pkgState dflags) findIdPrefix :: FilePath -> String -> SHM [(String, String)]@@ -325,16 +345,16 @@ findTypeOfName :: Session -> String -> SHM String findTypeOfName ses n = do -- prints an error to stderr for things that aren't expressions- maybe_tything <- io $ GHC.exprType ses n+ maybe_tything <- io $ GhcCompat.exprType ses n maybe (return "") (showForUser . ppr) maybe_tything where showForUser doc = do- unqual <- io $ GHC.getPrintUnqual ses+ unqual <- io $ GhcCompat.getPrintUnqual ses return $ showSDocForUser unqual doc evaluate :: Session -> String -> SHM String evaluate ses n = do- maybe_hvalue <- io $ GHC.compileExpr ses ("show (" ++ n ++ ")")+ maybe_hvalue <- io $ GhcCompat.compileExpr ses ("show (" ++ n ++ ")") -- prints errors to stderr? return $ maybe "" unsafeCoerce# maybe_hvalue @@ -348,19 +368,19 @@ "import Prelude ()", "import "++modname] load sourcefile False (Just minSrc)- modl <- io $ GHC.findModule ses (GHC.mkModuleName modname) Nothing+ modl <- io $ GhcCompat.findModule ses (GHC.mkModuleName modname) Nothing prel_mod <- io $ getPrelude ses- (as,bs) <- io (GHC.getContext ses)- io $ GHC.setContext ses [] [prel_mod,modl]- unqual <- io (GHC.getPrintUnqual ses)- io (GHC.setContext ses as bs)- mb_mod_info <- io $ GHC.getModuleInfo ses modl+ (as,bs) <- io (GhcCompat.getContext ses)+ io $ GhcCompat.setContext ses [] [prel_mod,modl]+ unqual <- io (GhcCompat.getPrintUnqual ses)+ io (GhcCompat.setContext ses as bs)+ mb_mod_info <- io $ GhcCompat.getModuleInfo ses modl case mb_mod_info of Nothing -> error "unknown module" Just mod_info -> do- let names = GHC.modInfoExports mod_info+ let names = modInfoExports mod_info things <- io $ forM names- (\n -> ((,) n) `liftM` GHC.lookupName ses n)+ (\n -> ((,) n) `liftM` GhcCompat.lookupName ses n) return $ filterPrefix pref $ map (\(n,t) ->@@ -382,18 +402,22 @@ pprExplicitForAlls :: SHM Bool pprExplicitForAlls = do s <- getSession- dflags <- io $ GHC.getSessionDynFlags s+ dflags <- io $ GhcCompat.getSessionDynFlags s return$ dopt Opt_PrintExplicitForalls dflags #endif findTypeOfPos :: FilePath -> Int -> Int -> Maybe String -> SHM String findTypeOfPos sourcefile line col source = do (cm,ses) <- checkModuleCached sourcefile source+#if __GLASGOW_HASKELL__ >= 610+ let modInfo = GHC.moduleInfo cm+#else let Just modInfo = GHC.checkedModuleInfo cm- unqual <- io$ GHC.getPrintUnqual ses+#endif+ unqual <- io$ GhcCompat.getPrintUnqual ses case findExprInCheckedModule line col cm of FoundName name -> do- mb_tyThing <- io $ GHC.modInfoLookupName ses modInfo name+ mb_tyThing <- io $ GhcCompat.modInfoLookupName ses modInfo name case mb_tyThing of Just tyThing -> return $! showSDocForUser unqual (pprTyThingInContextLoc True tyThing)
Shim/ProjectContent.hs view
@@ -1,102 +1,116 @@--- --- Copyright (c) Krasimir Angelov 2008. --- --- Extraction of the "Project View" from --- already configured Cabal package. --- - -module Shim.ProjectContent - ( loadProject - , ProjectItem(..) - , FileKind(..) - , FolderKind(..) - , ModuleKind(..) - ) where - -import Control.Monad.State -import Data.Tree -import Data.Tree.Zipper -import qualified Data.Set as Set -import Data.List (partition, nub) -import Distribution.Version -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Configure -import Distribution.Simple.Utils(dotToSep) -import Distribution.Simple.PreProcess(knownSuffixHandlers) -import Distribution.Simple.Setup (defaultDistPref) -import System.FilePath -import System.Directory - -data ProjectItem - = ProjectItem - { itemName :: String - , itemVersion:: Version - } - | DependenciesItem - { itemName :: String - } - | FolderItem - { itemName :: String - , folderKind :: FolderKind - } - | FileItem - { itemName :: String - , itemFPath :: FilePath - , fileKind :: FileKind - } - | PackageItem - { itemName :: String - , itemVersion:: Version - } - | ModuleItem - { itemName :: String - , itemFPath :: FilePath - , moduleKind :: ModuleKind - } - deriving (Eq, Ord, Show) - -data FileKind - = HsSource ModuleKind - | CSource - | HSource - | TextFile - | SetupScript - | LicenseText - deriving (Eq, Ord, Show) - -data FolderKind - = HsSourceFolder - | PlainFolder - deriving (Eq, Ord, Show) - -data ModuleKind - = ExposedModule - | HiddenModule - deriving (Eq, Ord, Show) - -loadProject :: FilePath -> IO (Tree ProjectItem, Tree ProjectItem) -loadProject projPath = do - Right lbi <- tryGetConfigStateFile (projPath </> localBuildInfoFile defaultDistPref) - let pkgDescr = localPkgDescr lbi - - root = ProjectItem (pkgName (package pkgDescr)) (pkgVersion (package pkgDescr)) - tloc1 = execState (addDependenciesTree (packageDeps lbi)) (getTop (Node root [])) - (mod_items,tloc2) <- case library pkgDescr of - Just lib -> addLibraryTree projPath (Set.empty,tloc1) lib - Nothing -> return (Set.empty,tloc1) - (mod_items,tloc2) <- foldM (addExecutableTree projPath) (mod_items,tloc2) (executables pkgDescr) - tloc3 <- checkAndAddFile projPath "Setup.hs" SetupScript tloc2 - tloc4 <- checkAndAddFile projPath "Setup.lhs" SetupScript tloc3 - let (hsources,extra_sources) = partition (\fpath -> takeExtension fpath == ".h") (extraSrcFiles pkgDescr) - tloc5 = execState (do mapM_ (addFilePath HSource projPath) hsources - mapM_ (addFilePath TextFile projPath) extra_sources - mapM_ (addFilePath TextFile projPath) (dataFiles pkgDescr) - addFilePath LicenseText projPath (licenseFile pkgDescr)) tloc4 - tloc6 = execState (mapM_ (\item -> insertDown item >> up) (Set.toList mod_items)) tloc1 - return (tree tloc5, tree tloc6) - +--+-- Copyright (c) Krasimir Angelov 2008.+--+-- Extraction of the "Project View" from+-- already configured Cabal package.+--++module Shim.ProjectContent+ ( loadProject+ , itemName+ , ProjectItem(..)+ , FileKind(..)+ , FolderKind(..)+ , ModuleKind(..)+ ) where++import Control.Monad.State+import Data.Tree+import Data.Tree.Zipper+import qualified Data.Set as Set+import Data.List (partition)+import Distribution.ModuleName+import Distribution.Version+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Configure+import Distribution.Simple.Utils(findFileWithExtension')+import Distribution.Simple.PreProcess(knownSuffixHandlers)+import Distribution.Simple.Setup (defaultDistPref)+import Distribution.Text+import System.FilePath+import System.Directory++data ProjectItem+ = ProjectItem+ { projItemName :: String+ , itemVersion :: Version+ }+ | DependenciesItem + { depItemName :: String+ }+ | FolderItem + { folderItemName :: String+ , folderKind :: FolderKind+ }+ | FileItem+ { fileItemName :: String+ , itemFPath :: FilePath+ , fileKind :: FileKind+ }+ | PackageItem+ { pkgItemName :: PackageName+ , itemVersion:: Version+ }+ | ModuleItem+ { modItemName :: ModuleName+ , itemFPath :: FilePath+ , moduleKind :: ModuleKind+ }+ deriving (Eq, Ord, Show)++itemName :: ProjectItem -> String+itemName ProjectItem {projItemName = n} = n+itemName DependenciesItem {depItemName = n} = n+itemName FolderItem {folderItemName = n} = n+itemName FileItem {fileItemName = n} = n+itemName PackageItem {pkgItemName = p} = display p+itemName ModuleItem {modItemName = m} = display m++++data FileKind+ = HsSource ModuleKind+ | CSource+ | HSource+ | TextFile+ | SetupScript+ | LicenseText+ deriving (Eq, Ord, Show)++data FolderKind+ = HsSourceFolder+ | PlainFolder+ deriving (Eq, Ord, Show)++data ModuleKind+ = ExposedModule+ | HiddenModule+ deriving (Eq, Ord, Show)+++loadProject :: FilePath -> IO (Tree ProjectItem, Tree ProjectItem)+loadProject projPath = do+ Right lbi <- tryGetConfigStateFile (projPath </> localBuildInfoFile defaultDistPref)+ let pkgDescr = localPkgDescr lbi++ root = PackageItem (pkgName (package pkgDescr)) (pkgVersion (package pkgDescr))+ tloc1 = execState (addDependenciesTree (packageDeps lbi)) (getTop (Node root []))+ (mod_items,tloc2) <- case library pkgDescr of+ Just lib -> addLibraryTree projPath (Set.empty,tloc1) lib+ Nothing -> return (Set.empty,tloc1)+ (mod_items,tloc2) <- foldM (addExecutableTree projPath) (mod_items,tloc2) (executables pkgDescr)+ tloc3 <- checkAndAddFile projPath "Setup.hs" SetupScript tloc2+ tloc4 <- checkAndAddFile projPath "Setup.lhs" SetupScript tloc3+ let (hsources,extra_sources) = partition (\fpath -> takeExtension fpath == ".h") (extraSrcFiles pkgDescr)+ tloc5 = execState (do mapM_ (addFilePath HSource projPath) hsources+ mapM_ (addFilePath TextFile projPath) extra_sources+ mapM_ (addFilePath TextFile projPath) (dataFiles pkgDescr)+ addFilePath LicenseText projPath (licenseFile pkgDescr)) tloc4+ tloc6 = execState (mapM_ (\item -> insertDown item >> up) (Set.toList mod_items)) tloc1+ return (tree tloc5, tree tloc6)+ getTop :: Tree a -> TreeLoc a getTop = fromTree @@ -110,18 +124,18 @@ modify' f = modify (\x -> maybe (error "impossible movement!") id (f x)) -addLibraryTree projPath (mod_items,tloc) (Library {libBuildInfo=binfo, exposedModules=exp_mods}) = do - (exp_mods,hid_mods,mod_items1,tloc1) <- foldM (\st dir -> addSourceDir projPath dir st) - (exp_mods,otherModules binfo,mod_items,tloc) - (hsSourceDirs binfo) - return $ (mod_items1,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc1) - -addExecutableTree projPath (mod_items,tloc) (Executable {modulePath=mainIs, buildInfo=binfo}) = do - let tloc1 = execState (addFilePath (HsSource ExposedModule) projPath mainIs) tloc - (exp_mods,hid_mods,mod_items2,tloc2) <- foldM (\st dir -> addSourceDir projPath dir st) - ([],otherModules binfo,mod_items,tloc1) - (hsSourceDirs binfo) - return $ (mod_items2,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc2) +addLibraryTree projPath (mod_items,tloc) (Library {libBuildInfo=binfo, exposedModules=exp_mods}) = do+ (exp_mods,hid_mods,mod_items1,tloc1) <- foldM (\st dir -> addSourceDir projPath dir st)+ (exp_mods,otherModules binfo,mod_items,tloc)+ (hsSourceDirs binfo)+ return $ (mod_items1,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc1)+ +addExecutableTree projPath (mod_items,tloc) (Executable {modulePath=mainIs, buildInfo=binfo}) = do+ let tloc1 = execState (addFilePath (HsSource ExposedModule) projPath mainIs) tloc+ (exp_mods,hid_mods,mod_items2,tloc2) <- foldM (\st dir -> addSourceDir projPath dir st)+ ([],otherModules binfo,mod_items,tloc1)+ (hsSourceDirs binfo)+ return $ (mod_items2,execState (mapM_ (addFilePath CSource projPath) (cSources binfo)) tloc2) addDependenciesTree deps = do insertDown (DependenciesItem "Dependencies")@@ -132,39 +146,39 @@ insertDown (PackageItem (pkgName dep) (pkgVersion dep)) up -addSourceDir :: FilePath -- ^ project location - -> FilePath -- ^ source sub-directory - -> ([String],[String],Set.Set ProjectItem,TreeLoc ProjectItem) - -> IO ([String],[String],Set.Set ProjectItem,TreeLoc ProjectItem) -addSourceDir projPath srcDir (exp_mods,hid_mods,mod_items,tloc) = do - let dir = projPath </> srcDir - (exp_paths,exp_mods) <- findModules dir exp_mods - (hid_paths,hid_mods) <- findModules dir hid_mods - let tloc1 = execState (addFilePath' (\c -> FolderItem c HsSourceFolder) (splitPath' srcDir) - (mapM_ (\(mod,loc) -> addFilePath (HsSource ExposedModule) dir loc) exp_paths >> - mapM_ (\(mod,loc) -> addFilePath (HsSource HiddenModule) dir loc) hid_paths)) - tloc - mod_items1 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) ExposedModule)) mod_items exp_paths - mod_items2 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) HiddenModule )) mod_items1 hid_paths - return (exp_mods,hid_mods,mod_items2,tloc1) - -addFilePath :: FileKind -> FilePath -> FilePath -> State (TreeLoc ProjectItem) () -addFilePath kind root fpath = addFilePath' (\c -> FileItem c (root </> fpath) kind) (splitPath' fpath) (return ()) - -addFilePath' :: (String -> ProjectItem) -> [String] - -> State (TreeLoc ProjectItem) () - -> State (TreeLoc ProjectItem) () -addFilePath' mkItem [] cont = cont -addFilePath' mkItem (c:cs) cont - | c == "." = addFilePath' mkItem cs cont - | otherwise = do let item | null cs = mkItem c - | otherwise = FolderItem c PlainFolder - children <- gets hasChildren - if children +addSourceDir :: FilePath -- ^ project location+ -> FilePath -- ^ source sub-directory+ -> ([ModuleName],[ModuleName],Set.Set ProjectItem,TreeLoc ProjectItem)+ -> IO ([ModuleName],[ModuleName],Set.Set ProjectItem,TreeLoc ProjectItem)+addSourceDir projPath srcDir (exp_mods,hid_mods,mod_items,tloc) = do+ let dir = projPath </> srcDir+ (exp_paths,exp_mods) <- findModules dir exp_mods+ (hid_paths,hid_mods) <- findModules dir hid_mods+ let tloc1 = execState (addFilePath' (\c -> FolderItem c HsSourceFolder) (splitPath' srcDir)+ (mapM_ (\(mod,loc) -> addFilePath (HsSource ExposedModule) dir loc) exp_paths >>+ mapM_ (\(mod,loc) -> addFilePath (HsSource HiddenModule) dir loc) hid_paths))+ tloc+ mod_items1 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) ExposedModule)) mod_items exp_paths+ mod_items2 = foldr (\(mod,loc) -> Set.insert (ModuleItem mod (dir </> loc) HiddenModule )) mod_items1 hid_paths+ return (exp_mods,hid_mods,mod_items2,tloc1)++addFilePath :: FileKind -> FilePath -> FilePath -> State (TreeLoc ProjectItem) ()+addFilePath kind root fpath = addFilePath' (\c -> FileItem c (root </> fpath) kind) (splitPath' fpath) (return ())++addFilePath' :: (String -> ProjectItem) -> [String] + -> State (TreeLoc ProjectItem) ()+ -> State (TreeLoc ProjectItem) ()+addFilePath' mkItem [] cont = cont+addFilePath' mkItem (c:cs) cont+ | c == "." = addFilePath' mkItem cs cont+ | otherwise = do let item | null cs = mkItem c+ | otherwise = FolderItem c PlainFolder+ children <- gets hasChildren+ if children then modify' firstChild >> insertItem c item else insertDown item- addFilePath' mkItem cs cont - up >> return () + addFilePath' mkItem cs cont+ up >> return () where insertItem :: Ord a => x -> a -> State (TreeLoc a) () insertItem c item = do@@ -179,54 +193,39 @@ simpleNode item = Node item [] -splitPath' fpath = [removeSlash c | c <- splitPath fpath] - where - removeSlash c - | null c = c - | isPathSeparator (last c) = init c - | otherwise = c - -checkAndAddFile projPath fpath kind tloc = do - let fullPath = projPath </> fpath - exists <- doesFileExist fullPath - if exists - then return $ execState (addFilePath kind fullPath fpath) tloc - else return tloc - -------------------------------------------------------------------------- --- Module Finder -------------------------------------------------------------------------- - -findModules :: FilePath -- ^source directory location - -> [String] -- ^module names - -> IO ([(String,FilePath)],[String]) -- ^found modules and unknown modules -findModules location [] = return ([],[]) -findModules location (mod:mods) = do - mb_paths <- findFileWithExtension' (map fst knownSuffixHandlers ++ ["hs", "lhs"]) [location] (dotToSep mod) - (locs,unks) <- findModules location mods - case mb_paths of - Just (_,loc) -> return ((mod,loc) : locs,unks) - Nothing -> return (locs,mod:unks) - - --- FIXME: The bellow two functions are copy+paste from the latest version of --- Cabal. Unfortunatelly they aren't exported in the current version of Cabal. --- Fix that after the next Cabal release. - -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry (</>)) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs +splitPath' fpath = [removeSlash c | c <- splitPath fpath]+ where+ removeSlash c+ | null c = c+ | isPathSeparator (last c) = init c+ | otherwise = c++checkAndAddFile projPath fpath kind tloc = do+ let fullPath = projPath </> fpath+ exists <- doesFileExist fullPath+ if exists+ then return $ execState (addFilePath kind fullPath fpath) tloc+ else return tloc++-------------------------------------------------------------------------+-- Module Finder+-------------------------------------------------------------------------++findModules :: FilePath -- ^source directory location+ -> [ModuleName] -- ^module names+ -> IO ([(ModuleName,FilePath)],[ModuleName]) -- ^found modules and unknown modules+findModules location [] = return ([],[])+findModules location (mod:mods) = do+ mb_paths <- findFileWithExtension' (map fst knownSuffixHandlers ++ ["hs", "lhs"]) [location] (toFilePath mod)+ (locs,unks) <- findModules location mods+ case mb_paths of+ Just (_,loc) -> return ((mod,loc) : locs,unks)+ Nothing -> return (locs,mod:unks)++findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)+findFirstFile file = findFirst+ where findFirst [] = return Nothing+ findFirst (x:xs) = do exists <- doesFileExist (file x)+ if exists+ then return (Just x)+ else findFirst xs
Shim/SHM.hs view
@@ -2,8 +2,15 @@ module Shim.SHM where import Data.Typeable++#if __GLASGOW_HASKELL__ >= 610+import GHC hiding ( load )+#else import GHC hiding ( load, newSession )+#endif+ import qualified GHC+import HscTypes import Outputable import ErrUtils @@ -16,6 +23,7 @@ import Shim.SessionMonad import Shim.Utils+import Shim.GhcCompat -------------------------------------------------------------- -- SHM Monad --------------------------------------------------------------@@ -39,7 +47,7 @@ type Hash = MD5.MD5Digest -type CachedMod = (Hash,CheckedModule)+type CachedMod = (Hash,TypecheckedModule) type CompBuffer = M.Map FilePath (CompilationResult, IdData, Maybe CachedMod) type SessionMap = M.Map FilePath Session@@ -77,7 +85,7 @@ getCompBuffer :: SHM CompBuffer getCompBuffer = gets compBuffer -addCompBuffer :: FilePath -> IdData -> CompilationResult -> Maybe (Hash,CheckedModule) -> SHM ()+addCompBuffer :: FilePath -> IdData -> CompilationResult -> Maybe (Hash,TypecheckedModule) -> SHM () addCompBuffer sourcefile id_data compilation_result checked_mod = modify (\s -> s{compBuffer=(M.insert sourcefile (compilation_result,id_data,checked_mod)
Shim/SessionMonad.hs view
@@ -1,6 +1,11 @@ module Shim.SessionMonad where -import GHC(Session)+#if __GLASGOW_HASKELL__ >= 610+import HscTypes (Session)+#else+import GHC (Session)+#endif class Monad m => SessionMonad m where getSession :: m Session +
Shim/Utils.hs view
@@ -38,7 +38,7 @@ import Data.Maybe import System.FilePath ( takeDirectory ) import Data.List ( elem )-import qualified Control.Exception as CE+-- import qualified Control.Exception as CE import System.IO.Unsafe ( unsafePerformIO ) import Control.Concurrent.MVar import Yi.Debug
Yi.hs view
@@ -32,7 +32,7 @@ import Yi.Dired import Yi.Eval import Yi.File-import Yi.Main (defaultConfig)+import Yi.Main (defaultConfig, availableFrontends) import Yi.Search import Yi.Style import Yi.Style.Library
Yi/Buffer/Basic.hs view
@@ -29,18 +29,12 @@ -- | 'direction' is in the same style of 'maybe' or 'either' functions, -- It takes one argument per direction (backward, then forward) and a -- direction to select the output.-direction :: a -> a -> Direction -> a-direction b _ Backward = b-direction _ f Forward = f+directionElim :: Direction -> a -> a -> a+directionElim Backward b _ = b+directionElim Forward _ f = f -- | A mark in a buffer newtype Mark = Mark {markId::Int} deriving (Eq, Ord, Show, Typeable, Binary)-staticInsMark, staticSelMark :: Mark-staticInsMark = Mark (-1) -- the insertion mark-staticSelMark = Mark (-2) -- the selection mark-dummyFromMark, dummyToMark :: Mark-dummyFromMark = Mark 1-dummyToMark = Mark 2 -- | Reference to a buffer. newtype BufferRef = BufferRef Int
Yi/Buffer/HighLevel.hs view
@@ -2,15 +2,14 @@ -- Copyright (C) 2008 JP Bernardy module Yi.Buffer.HighLevel where -import Prelude (FilePath)-import Yi.Prelude import Control.Applicative import Control.Monad.RWS.Strict (ask) import Control.Monad.State import Data.Char import Data.List (isPrefixOf, sort, lines, drop, filter, length, takeWhile, dropWhile)-import Data.Maybe- ( fromMaybe, listToMaybe )+import Data.Maybe (fromMaybe, listToMaybe)+import Prelude (FilePath, map)+import Yi.Prelude import Yi.Buffer.Basic import Yi.Buffer.Misc@@ -52,11 +51,11 @@ -- | Move to first char of next word forwards nextWordB :: BufferM ()-nextWordB = moveB Word Forward+nextWordB = moveB unitWord Forward -- | Move to first char of next word backwards prevWordB :: BufferM ()-prevWordB = moveB Word Backward+prevWordB = moveB unitWord Backward -- * Char-based movement actions. @@ -86,7 +85,11 @@ lastNonSpaceB = do moveToEol untilB_ ((||) <$> atSol <*> ((not . isSpace) <$> readB)) leftB -+-- | Go to the first non space character in the line;+-- if already there, then go to the beginning of the line.+moveNonspaceOrSol :: BufferM ()+moveNonspaceOrSol = do prev <- readPreviousOfLnB+ if and . map (isSpace) $ prev then moveToSol else firstNonSpaceB ------------ @@ -139,10 +142,17 @@ readLnB :: BufferM String readLnB = readUnitB Line +readCharB :: BufferM (Maybe Char)+readCharB = liftM listToMaybe (readUnitB Character)+ -- | Read from point to end of line readRestOfLnB :: BufferM String readRestOfLnB = readRegionB =<< regionOfPartB Line Forward +-- | Read from point to beginning of line+readPreviousOfLnB :: BufferM String+readPreviousOfLnB = readRegionB =<< regionOfPartB Line Backward+ -------------------------- -- Deletes @@ -153,12 +163,12 @@ -- | Delete forward whitespace or non-whitespace depending on -- the character under point. killWordB :: BufferM ()-killWordB = deleteB Word Forward+killWordB = deleteB unitWord Forward -- | Delete backward whitespace or non-whitespace depending on -- the character before point. bkillWordB :: BufferM ()-bkillWordB = deleteB Word Backward+bkillWordB = deleteB unitWord Backward ----------------------------------------@@ -166,15 +176,15 @@ -- | capitalise the word under the cursor uppercaseWordB :: BufferM ()-uppercaseWordB = transformB (fmap toUpper) Word Forward+uppercaseWordB = transformB (fmap toUpper) unitWord Forward -- | lowerise word under the cursor lowercaseWordB :: BufferM ()-lowercaseWordB = transformB (fmap toLower) Word Forward+lowercaseWordB = transformB (fmap toLower) unitWord Forward -- | capitalise the first letter of this word capitaliseWordB :: BufferM ()-capitaliseWordB = transformB capitalizeFirst Word Forward+capitaliseWordB = transformB capitalizeFirst unitWord Forward -- | Delete to the end of line, excluding it.@@ -183,12 +193,12 @@ -- | Delete whole line moving to the next line deleteLineForward :: BufferM ()-deleteLineForward = +deleteLineForward = do moveToSol -- Move to the start of the line deleteToEol -- Delete the rest of the line not including the newline char deleteN 1 -- Delete the newline character- + -- | Transpose two characters, (the Emacs C-t action) swapB :: BufferM () swapB = do eol <- atEol@@ -200,11 +210,11 @@ -- | Set the current buffer selection mark setSelectionMarkPointB :: Point -> BufferM ()-setSelectionMarkPointB = setMarkPointB staticSelMark+setSelectionMarkPointB p = flip setMarkPointB p =<< selMark <$> askMarks -- | Get the current buffer selection mark getSelectionMarkPointB :: BufferM Point-getSelectionMarkPointB = getMarkPointB staticSelMark+getSelectionMarkPointB = getMarkPointB =<< selMark <$> askMarks -- | Exchange point & mark. exchangePointAndMarkB :: BufferM ()@@ -271,7 +281,7 @@ upScreenB :: BufferM () upScreenB = scrollScreensB (-1) --- | Scroll up 1 screen+-- | Scroll down 1 screen downScreenB :: BufferM () downScreenB = scrollScreensB 1 @@ -281,10 +291,17 @@ h <- askWindow height scrollB $ n * (h - 1) +-- | Scroll according to function passed. The function takes the+-- | Window height in lines, its result is passed to scrollB+-- | (negative for up)+scrollByB :: (Int -> Int) -> Int -> BufferM ()+scrollByB f n = do h <- askWindow height+ scrollB $ n * (f h)+ -- | Scroll by n lines. scrollB :: Int -> BufferM () scrollB n = do setA pointDriveA False- WinMarks fr _ _ _ <- askMarks+ MarkSet fr _ _ _ <- askMarks savingPointB $ do moveTo =<< getMarkPointB fr gotoLnFrom n@@ -303,16 +320,11 @@ moveToSol replicateM_ n lineUp -askMarks :: BufferM WinMarks-askMarks = do- Just ms <- getMarks =<< ask- return ms- -- | Move to middle line in screen middleB :: BufferM () middleB = do w <- ask- Just (WinMarks f _ _ _) <- getMarks w+ f <- fromMark <$> askMarks moveTo =<< getMarkPointB f replicateM_ (height w `div` 2) lineDown @@ -323,23 +335,6 @@ ----------------------------- -- Region-related operations --- | Extend the given region to boundaries of the text unit.--- For instance one can extend the selection to complete lines, or--- paragraphs.-extendRegionToBoundaries :: TextUnit -> BoundarySide -> BoundarySide -> Region -> BufferM Region-extendRegionToBoundaries unit bs1 bs2 region = savingPointB $ do- moveTo $ regionStart region- genMaybeMoveB unit (Backward, bs1) Backward- start <- pointB- moveTo $ regionEnd region- genMaybeMoveB unit (Forward, bs2) Forward- stop <- pointB- return $ mkRegion' (regionDirection region) start stop--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@@ -348,13 +343,22 @@ instance Initializable SelectionStyle where initial = SelectionStyle Character -getRawSelectRegionB :: BufferM Region-getRawSelectRegionB = do- m <- getMarkPointB staticSelMark+-- | Return the region between point and mark+getRawestSelectRegionB :: BufferM Region+getRawestSelectRegionB = do+ m <- getSelectionMarkPointB p <- pointB return $ mkRegion p m --- | Get the current region boundaries+-- | Return the empty region if the selection is not visible.+getRawSelectRegionB :: BufferM Region+getRawSelectRegionB = do+ s <- getA highlightSelectionA+ if s then getRawestSelectRegionB else do+ p <- pointB+ return $ mkRegion p p++-- | Get the current region boundaries. Extended to the current selection unit. getSelectRegionB :: BufferM Region getSelectRegionB = do SelectionStyle unit <- getDynamicB@@ -364,7 +368,7 @@ -- and the current point at the 'regionEnd'. setSelectRegionB :: Region -> BufferM () setSelectRegionB region = do- setMarkPointB staticSelMark $ regionStart region+ setSelectionMarkPointB $ regionStart region moveTo $ regionEnd region -- | Extend the selection mark using the given region.@@ -389,7 +393,7 @@ -- in the given direction. lineStreamB :: Direction -> BufferM [String] lineStreamB dir = fmap (LazyUTF8.toString . rev) . drop 1 . LB.split newLine <$> (streamB dir =<< pointB)- where rev = case dir of + where rev = case dir of Forward -> id Backward -> LB.reverse @@ -437,7 +441,7 @@ modifyExtendedSelectionB :: TextUnit -> (String -> String) -> BufferM ()-modifyExtendedSelectionB unit transform +modifyExtendedSelectionB unit transform = modifyRegionB transform =<< unitWiseRegion unit =<< getSelectRegionB @@ -446,7 +450,7 @@ -- the same search and replace over multiple regions however we are -- unlikely to perform several search and replaces over the same region -- since the first such may change the bounds of the region.-searchReplaceRegionB :: +searchReplaceRegionB :: String -- ^ The String to search for -> String -- ^ The String to replace it with -> Region -- ^ The region to perform this over@@ -459,7 +463,7 @@ -- | Peform a search and replace on the selection-searchReplaceSelectionB :: +searchReplaceSelectionB :: String -- ^ The String to search for -> String -- ^ The String to replace it with@@ -467,43 +471,49 @@ searchReplaceSelectionB from to = modifySelectionB $ substituteInList from to +replaceString :: String -> String -> BufferM ()+replaceString a b = do end <- sizeB+ let region = mkRegion 0 end+ searchReplaceRegionB a b region -- | Prefix each line in the selection using -- the given string.-linePrefixSelectionB :: +linePrefixSelectionB :: String -- ^ The string that starts a line comment -> BufferM () -- The returned buffer action linePrefixSelectionB s = modifyExtendedSelectionB Line $ mapLines (s ++) --- | Comments the region using latex line comments-latexCommentSelectionB :: BufferM ()-latexCommentSelectionB = linePrefixSelectionB "% "- -- | Uncomments the selection using the given line comment -- starting string. This only works for the comments which -- begin at the start of the line. unLineCommentSelectionB :: String -- ^ The string which begins a line comment+ -> String -- ^ A potentially shorter string that begins a comment -> BufferM ()-unLineCommentSelectionB s =+unLineCommentSelectionB s1 s2 = modifyExtendedSelectionB Line $ mapLines unCommentLine where unCommentLine :: String -> String unCommentLine line- | isPrefixOf s line = drop (length s) line+ | isPrefixOf s1 line = drop (length s1) line+ | isPrefixOf s2 line = drop (length s2) line | otherwise = line --- | uncomments a region of latex line commented code-latexUnCommentSelectionB :: BufferM ()-latexUnCommentSelectionB = unLineCommentSelectionB "% "-+-- | Toggle line comments in the selection by adding or removing a prefix to each+-- line.+toggleCommentSelectionB :: String -> String -> BufferM ()+toggleCommentSelectionB insPrefix delPrefix = do+ l <- readUnitB Line+ if (delPrefix `isPrefixOf` l)+ then unLineCommentSelectionB insPrefix delPrefix+ else linePrefixSelectionB insPrefix --- Performs as search and replace on the given string.+-- | Performs as search and replace on the given string. substituteInList :: Eq a => [ a ] -> [ a ] -> [ a ] -> [ a ] substituteInList _from _to [] = [] substituteInList from to list@(h : rest)- | isPrefixOf from list = + | isPrefixOf from list = to ++ (substituteInList from to $ drop (length from) list) | otherwise = h : (substituteInList from to rest)
Yi/Buffer/Implementation.hs view
@@ -10,33 +10,23 @@ , updateIsDelete , Point , Mark, MarkValue(..)- , dummyFromMark- , dummyToMark- , staticInsMark- , staticSelMark , Size , Direction (..) , BufferImpl , Overlay, OvlLayer (..) , mkOverlay , overlayUpdate- , moveToI , applyUpdateI , isValidUpdate- , applyUpdateWithMoveI , reverseUpdateI- , pointBI , nelemsBI , nelemsBI' , sizeBI- , curLnI , newBI , gotoLnRelI--- , offsetFromSolBI , charsFromSolBI- , searchBI , regexRegionBI- , getMarkBI+ , getMarkDefaultPosBI , modifyMarkBI , getMarkValueBI , newMarkBI@@ -53,6 +43,7 @@ , getStream , getIndexedStream , newLine+ , lineAt , SearchExp ) where@@ -162,16 +153,12 @@ -------------------------------------------------- -- Low-level primitives. +dummyHlState :: HLState syntax dummyHlState = (HLState noHighlighter (hlStartState noHighlighter)) -- | New FBuffer filled from string. newBI :: LazyB.ByteString -> BufferImpl ()-newBI s = FBufferData (F.fromLazyByteString s) mks M.empty dummyHlState Set.empty 0- where mks = M.fromList [ (staticInsMark, MarkValue 0 insertGravity)- , (staticSelMark, MarkValue 0 selectionGravity)- , (dummyFromMark, MarkValue 0 Backward)- , (dummyToMark, MarkValue 0 Forward)- ]+newBI s = FBufferData (F.fromLazyByteString s) M.empty M.empty dummyHlState Set.empty 0 -- | read @n@ chars from buffer @b@, starting at @i@ readChars :: ByteRope -> Int -> Point -> String@@ -228,11 +215,6 @@ sizeBI :: BufferImpl syntax -> Point sizeBI fb = Point $ F.length $ mem fb --- | Extract the current point-pointBI :: BufferImpl syntax -> Point-pointBI fb = markPoint ((marks fb) M.! staticInsMark)-{-# INLINE pointBI #-}- -- | Return @n@ Chars starting at @i@ of the buffer as a list nelemsBI :: Int -> Point -> BufferImpl syntax -> String nelemsBI n i fb = readChars (mem fb) n i@@ -276,8 +258,8 @@ -- the buffer. In each list, the strokes are guaranteed to be -- ordered and non-overlapping. The lists of strokes are ordered by -- decreasing priority: the 1st layer should be "painted" on top.-strokesRangesBI :: Maybe SearchExp -> Region -> BufferImpl syntax -> [[Stroke]]-strokesRangesBI regex rgn fb@(FBufferData {hlCache = HLState hl cache}) = result+strokesRangesBI :: Maybe SearchExp -> Region -> Point -> BufferImpl syntax -> [[Stroke]]+strokesRangesBI regex rgn point fb@(FBufferData {hlCache = HLState hl cache}) = result where i = regionStart rgn j = regionEnd rgn@@ -292,19 +274,12 @@ Nothing -> [] result = map (map clampStroke . takeIn . dropBefore) (layer3 : layers2 ++ [syntaxHlLayer, groundLayer]) overlayStroke (Overlay _ sm em a) = (markPoint sm, a, markPoint em)- point = pointBI fb clampStroke (l,x,r) = (max i l, x, min j r) hintStroke r = (regionStart r,if point `nearRegion` r then strongHintStyle else hintStyle,regionEnd r) ------------------------------------------------------------------------ -- Point based editing --- | Move point in buffer to the given index-moveToI :: Point -> BufferImpl syntax -> BufferImpl syntax-moveToI i fb = fb {marks = M.insert staticInsMark (MarkValue (inBounds i (Point end)) insertGravity) $ marks fb}- where end = F.length (mem fb)-{-# INLINE moveToI #-}- findNextChar :: Int -> Point -> BufferImpl syntax -> Point findNextChar m p fb | m < 0 = case drop (0 - 1 - m) (getIndexedStream Backward p fb) of@@ -337,14 +312,6 @@ p = mem fb -- FIXME: remove collapsed overlays --- | Apply a /valid/ update and also move point in buffer to update position-applyUpdateWithMoveI :: Update -> BufferImpl syntax -> BufferImpl syntax-applyUpdateWithMoveI u = case updateDirection u of- Forward -> apply . move- Backward -> move . apply- where move = moveToI (updatePoint u)- apply = applyUpdateI u- -- | Reverse the given update reverseUpdateI :: Update -> Update reverseUpdateI (Delete p dir cs) = Insert p (reverseDir dir) cs@@ -360,23 +327,21 @@ newLine :: Word8 newLine = ord' '\n' -curLnI :: BufferImpl syntax -> Int-curLnI fb = 1 + F.count newLine (F.take (fromPoint $ pointBI fb) (mem fb))+lineAt :: Point -> BufferImpl syntax -> Int+lineAt point fb = 1 + F.count newLine (F.take (fromPoint point) (mem fb)) --- | Go to line number @n@, relatively from this line. @0@ will go to+-- | Get the point at line number @n@, relatively from @point@. @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) -- Note that the line-difference returned will be negative if we are -- going backwards to previous lines (that is if @n@ was negative).-gotoLnRelI :: Int -> BufferImpl syntax -> (BufferImpl syntax, Int)-gotoLnRelI n fb = - (moveToI (Point newPoint) fb, difference)+gotoLnRelI :: Int -> Point -> BufferImpl syntax -> (Point, Int)+gotoLnRelI n (Point point) fb = (Point newPoint, difference) where -- The text of the buffer s = mem fb -- The current point that we are at in the buffer.- Point point = pointBI fb (difference, newPoint) -- Important that we go up if it is 0 since findDownLine -- fails for zero.@@ -416,31 +381,9 @@ findDownLine acc 1 (x:_) = (acc, x) findDownLine acc l (_:xs) = findDownLine (acc + 1) (l - 1) xs --- | Return index of next string in buffer that matches argument-searchBI :: Direction -> String -> BufferImpl syntax -> Maybe Point-searchBI dir s fb = fmap Point $ case dir of- Forward -> fmap (pnt +) $ F.findSubstring (UTF8.fromString s) $ F.drop pnt ptr- Backward -> listToMaybe $ reverse $ F.findSubstrings (UTF8.fromString s) $ F.take (pnt + length s) ptr- -- FIXME: backward search is inefficient.- where Point pnt = pointBI fb -- pnt == current point- ptr = mem fb--offsetToEolBI fb = Size $ case (F.elemIndices newLine) (F.drop point s) of- [] -> F.length s - point- (x:_) -> x- where s = mem fb- Point point = pointBI fb- --offsetFromSolBI :: BufferImpl syntax -> Size-offsetFromSolBI fb = Size (pnt - maybe 0 (1 +) (F.elemIndexEnd newLine (F.take pnt ptr)))- where Point pnt = pointBI fb- ptr = mem fb--charsFromSolBI :: BufferImpl syntax -> String-charsFromSolBI fb = LazyUTF8.toString $ F.toLazyByteString $ readChunk ptr (Size (pnt - sol)) (Point sol)+charsFromSolBI :: Point -> BufferImpl syntax -> String+charsFromSolBI (Point pnt) fb = LazyUTF8.toString $ F.toLazyByteString $ readChunk ptr (Size (pnt - sol)) (Point sol) where sol = maybe 0 (1 +) (F.elemIndexEnd newLine (F.take pnt ptr))- Point pnt = pointBI fb ptr = mem fb @@ -456,15 +399,13 @@ newMarkBI :: MarkValue -> BufferImpl syntax -> (BufferImpl syntax, Mark) newMarkBI initialValue fb =- let (Mark maxId, _) = M.findMax (marks fb)+ let maxId = maybe 0 id $ markId . fst . fst <$> M.maxViewWithKey (marks fb) newMark = Mark $ maxId + 1 fb' = fb { marks = M.insert newMark initialValue (marks fb)} in (fb', newMark) -getMarkValueBI :: Mark -> BufferImpl syntax -> MarkValue-getMarkValueBI m (FBufferData { marks = marksMap } ) = M.findWithDefault (marksMap M.! staticInsMark) m marksMap- -- We look up mark m in the marks, the default value to return- -- if mark m is not set, is the staticInsMark+getMarkValueBI :: Mark -> BufferImpl syntax -> Maybe MarkValue+getMarkValueBI m (FBufferData { marks = marksMap } ) = M.lookup m marksMap -- | Modify a mark value. modifyMarkBI :: Mark -> (MarkValue -> MarkValue) -> (forall syntax. BufferImpl syntax -> BufferImpl syntax)@@ -514,15 +455,7 @@ | otherwise = x : decodeBack xs -- continue -insertGravity, selectionGravity :: Direction-insertGravity = Forward-selectionGravity = Backward- ---------------------------------------------------------------------------- | Returns the requested mark, creating a new mark with that name (at point) if needed-getMarkBI :: Maybe String -> BufferImpl syntax -> (BufferImpl syntax, 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 -> Point -> BufferImpl syntax -> (BufferImpl syntax, Mark)
Yi/Buffer/Indent.hs view
@@ -20,9 +20,8 @@ import Data.List (span, length, sort, nub, break, reverse, filter, takeWhile) import Yi.String - {- |- Inserts either a \t or the number of spaces specified by tabSize in the+ Insert either a \t or the number of spaces specified by tabSize in the IndentSettings. Note that if you actually want to insert a tab character (for example when editing makefiles) then you should use: @insertB '\t'@. -}@@ -37,7 +36,7 @@ Retrieve the current indentation settings for the buffer. -} indentSettingsB :: BufferM IndentSettings-indentSettingsB = withModeB (\Mode {modeIndentSettings = x} -> x)+indentSettingsB = withModeB (\Mode {modeIndentSettings = x} -> return x) {-|@@ -46,7 +45,7 @@ specialise 'autoIndentHelperB' on their own. -} autoIndentB :: IndentBehaviour -> BufferM ()-autoIndentB indentBehave =+autoIndentB indentBehave = do autoIndentHelperB fetchPreviousIndentsB indentsOfString indentBehave where -- Returns the indentation hints considering the given@@ -55,11 +54,12 @@ -- The indent of the given string -- The indent of the given string plus two -- The offset of the last open bracket if any in the line.- indentsOfString :: String -> BufferM [ Int ]+ indentsOfString :: String -> BufferM [Int] indentsOfString input = do indent <- indentOfB input bracketHints <- lastOpenBracketHint input- return $ indent : (indent + 2) : bracketHints+ indentSettings <- indentSettingsB+ return $ indent : (indent + shiftWidth indentSettings) : bracketHints {-| This takes two arguments the first is a function to@@ -84,7 +84,7 @@ -- ^ Action to calculate hints from previous line -> IndentBehaviour -- ^ Sets the indent behaviour, - --- see 'Yi.Buffer.IndentBehaviour' for a description+ -- see 'Yi.Buffer.IndentBehaviour' for a description -> BufferM () autoIndentHelperB getUpwards getPrevious indentBehave = do upwardHints <- savingExcursionB getUpwards@@ -377,33 +377,9 @@ of the line then we wish to remain pointing to the same character. -} indentToB :: Int -> BufferM ()-indentToB level = - -- Grab the current line- do line <- readLnB- -- grab the current offset (in characters) from the start of the line- currentOffset <- curCol- -- move to the start of the line- moveToSol- -- delete the whole of the line.- deleteToEol- -- Separate the white space of the current line from the rest of it.- let (curIndent, restOfLine) = span isSpace line- -- The original offset (in characters) from the start of the rest- -- the line, this will be greater than zero if the current point- -- was somewhere after the indentation of the current line.- origOffsetFromIndent = currentOffset - (length curIndent)- -- This calculates how far we should be from the end of the line.- -- if we are within the line then we wish to remain at the same- -- character, however if we were anywhere within the indentation- -- we wish to go to the start of the 'non' indentation, that is- -- to the end of the (new) indentation.- newFromEol = if origOffsetFromIndent <= 0- then length restOfLine- else (length restOfLine - origOffsetFromIndent)- -- Insert the new line- insertN (replicate level ' ' ++ restOfLine)- -- Then move to the place we have calculated- leftN newFromEol+indentToB level = do+ indentSettings <- indentSettingsB+ modifyRegionClever (rePadString indentSettings level) =<< regionOfB Line -- | Indent as much as the previous line indentAsPreviousB :: BufferM ()@@ -413,20 +389,27 @@ indentToB previousIndent --- | --- shifts right (or left if num is negative) num times, filling in tabs if++-- | Set the padding of the string to newCount, filling in tabs if -- expandTabs is set in the buffers IndentSettings-indentString :: IndentSettings -> Int -> String -> String-indentString indentSettings numOfShifts input +rePadString :: IndentSettings -> Int -> String -> String+rePadString indentSettings newCount input | newCount <= 0 = rest | expandTabs indentSettings = replicate newCount ' ' ++ rest | otherwise = tabs ++ spaces ++ rest- where (indents,rest) = span isSpace input+ where (_indents,rest) = span isSpace input+ tabs = replicate (newCount `div` (tabSize indentSettings)) '\t'+ spaces = replicate (newCount `mod` (tabSize indentSettings)) ' '+++-- | shifts right (or left if num is negative) num times, filling in tabs if+-- expandTabs is set in the buffers IndentSettings+indentString :: IndentSettings -> Int -> String -> String+indentString indentSettings numOfShifts input = rePadString indentSettings newCount input + where (indents,_) = span isSpace input countSpace '\t' = tabSize indentSettings countSpace _ = 1 -- we'll assume nothing but tabs and spaces newCount = sum (fmap countSpace indents) + ((shiftWidth indentSettings) * numOfShifts)- tabs = replicate (newCount `div` (tabSize indentSettings)) '\t'- spaces = replicate (newCount `mod` (tabSize indentSettings)) ' ' shiftIndentOfSelection :: Int -> BufferM ()@@ -450,4 +433,4 @@ -- | Decreases the indentation on the region by the given amount decreaseIndentSelectionB :: Int -> BufferM () decreaseIndentSelectionB i =- unLineCommentSelectionB $ replicate i ' '+ let pre = replicate i ' ' in unLineCommentSelectionB pre pre
Yi/Buffer/Misc.hs view
@@ -9,7 +9,7 @@ module Yi.Buffer.Misc ( FBuffer (..) , BufferM (..)- , WinMarks (..)+ , WinMarks, MarkSet (..) , getMarks , runBuffer , runBufferFull@@ -63,7 +63,6 @@ , modifyMode , regexRegionB , regexB- , searchB , readAtB , getModeLine , getPercent@@ -78,6 +77,7 @@ , savingPointB , pendingUpdatesA , highlightSelectionA+ , rectangleSelectionA , revertPendingUpdatesB , askWindow , clearSyntax@@ -87,6 +87,7 @@ , IndentSettings (..) , emptyMode , withModeB+ , withMode0 , onMode , withSyntax0 , withSyntaxB@@ -95,15 +96,21 @@ , streamB , indexedStreamB , getMarkPointB+ , askMarks , pointAt , fileA , nameA , pointDriveA , SearchExp+ , charIndexB+ , byteIndexB+ , charRegionB+ , byteRegionB+ , indexStreamRegionB ) where -import Prelude (ceiling)+import Prelude (ceiling, span, unzip, take, drop) import Yi.Prelude import Yi.Region import System.FilePath@@ -113,10 +120,11 @@ import Yi.Buffer.Undo import Yi.Dynamic import Yi.Window-import Control.Monad.RWS.Strict hiding (mapM_, mapM, get, put)+import Control.Monad.RWS.Strict hiding (mapM_, mapM, get, put, forM) import Data.Binary import Data.List (scanl, takeWhile, zip, length) import qualified Data.Map as M+import Data.Maybe import Data.Typeable import {-# source #-} Yi.Keymap import Yi.Monad@@ -147,12 +155,21 @@ -- * Log of updates mades -- * Undo -data WinMarks = WinMarks { fromMark, insMark, selMark, toMark :: !Mark }+type WinMarks = MarkSet Mark -instance Binary WinMarks where- put (WinMarks f i s t) = put f >> put i >> put s >> put t- get = WinMarks <$> get <*> get <*> get <*> get+data MarkSet a = MarkSet { fromMark, insMark, selMark, toMark :: !a } +instance Traversable MarkSet where+ traverse f (MarkSet a b c d) = MarkSet <$> f a <*> f b <*> f c <*> f d+instance Foldable MarkSet where+ foldMap = foldMapDefault+instance Functor MarkSet where+ fmap = fmapDefault++instance Binary a => Binary (MarkSet a) where+ put (MarkSet f i s t) = put f >> put i >> put s >> put t+ get = MarkSet <$> get <*> get <*> get <*> get+ data FBuffer = forall syntax. FBuffer { name :: !String -- ^ immutable buffer name , bkey :: !BufferRef -- ^ immutable unique key@@ -165,93 +182,119 @@ , bufferDynamic :: !DynamicValues -- ^ dynamic components , preferCol :: !(Maybe Int) -- ^ prefered column to arrive at when we do a lineDown / lineUp , pendingUpdates :: ![UIUpdate] -- ^ updates that haven't been synched in the UI yet- , highlightSelection :: !Bool+ , selectionStyle :: !SelectionStyle , process :: !KeymapProcess , winMarks :: !(M.Map WindowRef WinMarks)+ , lastActiveWindow :: !Window } deriving Typeable -- unfortunately the dynamic stuff can't be read. instance Binary FBuffer where- put (FBuffer n b f u r bmode pd _bd pc pu hs _proc wm) =+ put (FBuffer n b f u r bmode pd _bd pc pu hs _proc wm law) = let strippedRaw :: BufferImpl () strippedRaw = (setSyntaxBI (modeHL emptyMode) r) in do put (modeName bmode) put n >> put b >> put f >> put u >> put strippedRaw put pd >> put pc >> put pu >> put hs >> put wm- + put law get = do mnm <- get FBuffer <$> get <*> get <*> get <*> get <*> getStripped <*>- pure (emptyMode {modeName = mnm}) <*> get <*> pure emptyDV <*> get <*> get <*> get <*> pure I.End <*> get+ pure (emptyMode {modeName = mnm}) <*> get <*> pure emptyDV <*> get <*> get <*> get <*> pure I.End <*> get <*> get where getStripped :: Get (BufferImpl ()) getStripped = get +data SelectionStyle = SelectionStyle+ { highlightSelection :: !Bool+ , rectangleSelection :: !Bool+ }+ deriving Typeable++instance Binary SelectionStyle where+ put (SelectionStyle h r) = put h >> put r+ get = SelectionStyle <$> get <*> get+ -- | udpate the syntax information (clear the dirty "flag") clearSyntax :: FBuffer -> FBuffer clearSyntax = modifyRawbuf updateSyntax modifyRawbuf :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> FBuffer -> FBuffer-modifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = - (FBuffer f1 f2 f3 f4 (f f5) f6 f7 f8 f9 f10 f11 f12 f13)+modifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14) = + (FBuffer f1 f2 f3 f4 (f f5) f6 f7 f8 f9 f10 f11 f12 f13 f14) queryAndModifyRawbuf :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> FBuffer -> (FBuffer, x)-queryAndModifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) = +queryAndModifyRawbuf f (FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14) = let (f5', x) = f f5- in (FBuffer f1 f2 f3 f4 f5' f6 f7 f8 f9 f10 f11 f12 f13, x)+ in (FBuffer f1 f2 f3 f4 f5' f6 f7 f8 f9 f10 f11 f12 f13 f14, x) +lastActiveWindowA :: Accessor FBuffer Window+lastActiveWindowA = Accessor lastActiveWindow (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 (f f14))+ pointDriveA :: Accessor FBuffer Bool pointDriveA = Accessor pointDrive (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 (f f7) f8 f9 f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 (f f7) f8 f9 f10 f11 f12 f13 f14) undosA :: Accessor (FBuffer) (URList) undosA = Accessor undos (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 (f f4) f5 f6 f7 f8 f9 f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 (f f4) f5 f6 f7 f8 f9 f10 f11 f12 f13 f14) fileA :: Accessor (FBuffer) (Maybe FilePath) fileA = Accessor file (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 (f f3) f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 (f f3) f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14) preferColA :: Accessor (FBuffer) (Maybe Int) preferColA = Accessor preferCol (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 (f f9) f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 (f f9) f10 f11 f12 f13 f14) bufferDynamicA :: Accessor (FBuffer) (DynamicValues) bufferDynamicA = Accessor bufferDynamic (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 (f f8) f9 f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 (f f8) f9 f10 f11 f12 f13 f14) pendingUpdatesA :: Accessor (FBuffer) ([UIUpdate]) pendingUpdatesA = Accessor pendingUpdates (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 (f f10) f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 (f f10) f11 f12 f13 f14) +selectionStyleA :: Accessor FBuffer SelectionStyle+selectionStyleA = Accessor selectionStyle (\f e -> case e of + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 (f f11) f12 f13 f14)+ highlightSelectionA :: Accessor FBuffer Bool-highlightSelectionA = Accessor highlightSelection (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 (f f11) f12 f13)+highlightSelectionA = + Accessor highlightSelection (\f e -> e { highlightSelection = f (highlightSelection e) })+ .> selectionStyleA +rectangleSelectionA :: Accessor FBuffer Bool+rectangleSelectionA = + Accessor rectangleSelection (\f e -> e { rectangleSelection = f (rectangleSelection e) })+ .> selectionStyleA+ nameA :: Accessor FBuffer String nameA = Accessor name (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer (f f1) f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer (f f1) f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14) keymapProcessA :: Accessor FBuffer KeymapProcess keymapProcessA = Accessor process (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 (f f12) f13)+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 (f f12) f13 f14) winMarksA :: Accessor FBuffer (M.Map Int WinMarks) winMarksA = Accessor winMarks (\f e -> case e of - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 -> - FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 (f f13))+ FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 -> + FBuffer f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 (f f13) f14) @@ -272,15 +315,16 @@ data Mode syntax = Mode {- modeName :: String, -- ^ so this could be serialized, debugged.+ modeName :: String, -- ^ so this can be serialized, debugged. modeApplies :: FilePath -> Bool, -- ^ What type of files does this mode apply to?- modeHL :: ExtHL syntax,- modePrettify :: syntax -> BufferM (),+ modeHL :: ExtHL syntax, -- ^ Syntax highlighter+ modePrettify :: syntax -> BufferM (), -- ^ Prettify current "paragraph" modeKeymap :: KeymapEndo, -- ^ Buffer-local keymap modification- modeIndent :: syntax -> IndentBehaviour -> BufferM (),- modeAdjustBlock :: syntax -> Int -> BufferM (),- modeFollow :: syntax -> Action,- modeIndentSettings :: IndentSettings+ modeIndent :: syntax -> IndentBehaviour -> BufferM (), -- ^ emacs-style auto-indent line+ modeAdjustBlock :: syntax -> Int -> BufferM (), -- ^ adjust the indentation after modification+ modeFollow :: syntax -> Action, -- ^ Follow a "link" in the file. (eg. go to location of error message)+ modeIndentSettings :: IndentSettings,+ modeToggleCommentSelection :: BufferM () } instance Binary (Mode syntax) where@@ -306,7 +350,11 @@ -- | The BufferM monad writes the updates performed. newtype BufferM a = BufferM { fromBufferM :: RWS Window [Update] FBuffer a }+#if __GLASGOW_HASKELL__ >= 610+ deriving (Monad, Functor, MonadWriter [Update], MonadState FBuffer, MonadReader Window, Typeable)+#else deriving (Monad, Functor, MonadWriter [Update], MonadState FBuffer, MonadReader Window, Typeable1)+#endif deriving instance Typeable4 RWS @@ -332,7 +380,7 @@ ln <- curLn p <- pointB s <- sizeB- modeNm <- withModeB modeName+ modeNm <- gets (withMode0 modeName) unchanged <- isUnchangedB let pct = if pos == 1 then "Top" else getPercent p s chg = if unchanged then "-" else "*"@@ -352,7 +400,7 @@ where p = ceiling ((fromIntegral a) / (fromIntegral b) * 100 :: Double) :: Int queryBuffer :: (forall syntax. BufferImpl syntax -> x) -> (BufferM x)-queryBuffer f = gets (\(FBuffer _ _ _ _ fb _ _ _ _ _ _ _ _) -> f fb)+queryBuffer f = gets (\(FBuffer _ _ _ _ fb _ _ _ _ _ _ _ _ _) -> f fb) modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM () modifyBuffer f = modify (modifyRawbuf f)@@ -386,34 +434,33 @@ getMarks :: Window -> BufferM (Maybe WinMarks) getMarks w = do getsA winMarksA (M.lookup $ wkey w) - + + runBufferFull :: Window -> FBuffer -> BufferM a -> (a, [Update], FBuffer) runBufferFull w b f = let (a, b', updates) = runRWS (fromBufferM f') w b f' = do ms <- getMarks w- (i,s) <- case ms of- Just (WinMarks _ i s _) -> do- copyMark i staticInsMark- copyMark s staticSelMark- return (i,s)- Nothing -> do- -- copy marks from random window.- (_, WinMarks fr i s t) <- M.findMax <$> getA winMarksA- markValues <- mapM getMarkValueB [fr, i, s, t]- [newFrom, newIns, newSel, newTo] <- mapM newMarkB markValues- modifyA winMarksA (M.insert (wkey w) (WinMarks newFrom newIns newSel newTo))- return (newIns,newSel)- f <* copyMark staticInsMark i <* copyMark staticSelMark s+ when (isNothing ms) $ do+ -- this window has no marks for this buffer yet; have to create them.+ newMarkValues <- if wkey (lastActiveWindow b) == dummyWindowKey+ then return+ -- no previous window, create some marks from scratch.+ MarkSet { insMark = MarkValue 0 Forward,+ selMark = MarkValue 0 Backward, -- sel+ fromMark = MarkValue 0 Backward, -- from+ toMark = MarkValue 0 Forward } -- to+ else do+ Just mrks <- getsA winMarksA (M.lookup $ wkey (lastActiveWindow b))+ forM mrks getMarkValueB+ newMrks <- forM newMarkValues newMarkB+ modifyA winMarksA (M.insert (wkey w) newMrks)+ setA lastActiveWindowA w+ f in (a, updates, modifier pendingUpdatesA (++ fmap TextUpdate updates) b') -copyMark :: Mark -> Mark -> BufferM ()-copyMark src dst = do- p <- getMarkValueB src- setMarkPointB dst (markPoint p)- getMarkValueB :: Mark -> BufferM MarkValue-getMarkValueB m = queryBuffer (getMarkValueBI m)+getMarkValueB m = maybe (MarkValue 0 Forward) id <$> queryBuffer (getMarkValueBI m) newMarkB :: MarkValue -> BufferM Mark newMarkB v = queryAndModify $ newMarkBI v@@ -438,10 +485,11 @@ isUnchangedBuffer = isAtSavedFilePointU . undos -undoRedo :: (forall syntax. URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update])) ) -> BufferM ()+undoRedo :: (forall syntax. Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update])) ) -> BufferM () undoRedo f = do+ m <- getInsMark ur <- gets undos- (ur', updates) <- queryAndModify (f ur)+ (ur', updates) <- queryAndModify (f m ur) setA undosA ur' tell updates @@ -466,7 +514,8 @@ { expandTabs = True , tabSize = 8 , shiftWidth = 4- }+ },+ modeToggleCommentSelection = fail "'comment selection' not defined for this mode" } -- | Create buffer named @nm@ with contents @s@@@ -483,9 +532,10 @@ , preferCol = Nothing , bufferDynamic = emptyDV , pendingUpdates = []- , highlightSelection = False+ , selectionStyle = SelectionStyle False False , process = I.End- , winMarks = M.singleton dummyWindowKey (WinMarks dummyFromMark staticInsMark staticSelMark dummyToMark)+ , winMarks = M.empty+ , lastActiveWindow = dummyWindow unique } -- | Point of eof@@ -494,8 +544,9 @@ -- | Extract the current point pointB :: BufferM Point-pointB = queryBuffer pointBI+pointB = getMarkPointB =<< getInsMark + -- | Return @n@ elems starting at @i@ of the buffer as a list nelemsB :: Int -> Point -> BufferM [Char] nelemsB n i = queryBuffer $ nelemsBI n i@@ -511,7 +562,9 @@ indexedStreamB dir i = queryBuffer (getIndexedStream dir i) strokesRangesB :: Maybe SearchExp -> Region -> BufferM [[Stroke]]-strokesRangesB regex r = queryBuffer $ strokesRangesBI regex r+strokesRangesB regex r = do+ p <- pointB+ queryBuffer $ strokesRangesBI regex r p ------------------------------------------------------------------------ -- Point based operations@@ -520,7 +573,7 @@ moveTo :: Point -> BufferM () moveTo x = do forgetPreferCol- modifyBuffer $ moveToI x+ flip setMarkPointB x =<< getInsMark ------------------------------------------------------------------------ @@ -589,7 +642,9 @@ -- | Return the current line number curLn :: BufferM Int-curLn = queryBuffer curLnI+curLn = do + p <- pointB+ queryBuffer (lineAt p) -- | 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,@@ -600,18 +655,14 @@ --------------------------------------------------------------------- --- | Return index of next (or previous) string in buffer that matches argument-searchB :: Direction -> [Char] -> BufferM (Maybe Point)-searchB dir s = queryBuffer (searchBI dir s)- setMode0 :: forall syntax. Mode syntax -> FBuffer -> FBuffer-setMode0 m (FBuffer f1 f2 f3 f4 rb _ f7 f8 f9 f10 f11 f12 f13) =- (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m) rb) m f7 f8 f9 f10 f11 f12 f13)+setMode0 m (FBuffer f1 f2 f3 f4 rb _ f7 f8 f9 f10 f11 f12 f13 f14) =+ (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m) rb) m f7 f8 f9 f10 f11 f12 f13 f14) modifyMode0 :: (forall syntax. Mode syntax -> Mode syntax) -> FBuffer -> FBuffer-modifyMode0 f (FBuffer f1 f2 f3 f4 rb m f7 f8 f9 f10 f11 f12 f13) =+modifyMode0 f (FBuffer f1 f2 f3 f4 rb m f7 f8 f9 f10 f11 f12 f13 f14) = let m' = f m- in (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m') rb) m' f7 f8 f9 f10 f11 f12 f13)+ in (FBuffer f1 f2 f3 f4 (setSyntaxBI (modeHL m') rb) m' f7 f8 f9 f10 f11 f12 f13 f14) -- | Set the mode@@ -639,8 +690,10 @@ withMode0 f FBuffer {bmode = m} = f m -withModeB :: (forall syntax. Mode syntax -> a) -> BufferM a-withModeB f = gets (withMode0 f)+withModeB :: (forall syntax. Mode syntax -> BufferM a) -> BufferM a+withModeB f = do+ act <- gets (withMode0 f)+ act withSyntax0 :: (forall syntax. Mode syntax -> syntax -> a) -> FBuffer -> a withSyntax0 f FBuffer {bmode = m, rawbuf = rb} = f m (getAst rb)@@ -676,9 +729,21 @@ setVisibleSelection :: Bool -> BufferM () setVisibleSelection = setA highlightSelectionA +getInsMark :: BufferM Mark+getInsMark = insMark <$> askMarks++askMarks :: BufferM WinMarks+askMarks = do+ Just ms <- getMarks =<< ask+ return ms+ getMarkB :: Maybe String -> BufferM Mark-getMarkB m = queryAndModify (getMarkBI m)+getMarkB m = do+ p <- pointB+ queryAndModify (getMarkDefaultPosBI m p) + + -- | Move point by the given number of characters. -- A negative offset moves backwards a positive one forward. moveN :: Int -> BufferM ()@@ -775,7 +840,8 @@ -- (This takes into account tabs, unicode chars, etc.) curCol :: BufferM Int curCol = do - chars <- queryBuffer charsFromSolBI+ p <- pointB+ chars <- queryBuffer (charsFromSolBI p) return (foldl colMove 0 chars) colMove :: Int -> Char -> Int@@ -787,7 +853,11 @@ -- Returns the actual moved difference which of course -- may be negative if the requested difference was negative. gotoLnFrom :: Int -> BufferM Int-gotoLnFrom x = queryAndModify $ gotoLnRelI x+gotoLnFrom x = do+ p <- pointB+ (p',lineDiff) <- queryBuffer $ gotoLnRelI x p + moveTo p'+ return lineDiff bufferDynamicValueA :: Initializable a => Accessor FBuffer a bufferDynamicValueA = dynamicValueA .> bufferDynamicA@@ -827,4 +897,37 @@ askWindow :: (Window -> a) -> BufferM a askWindow = asks++-------------+-- Character-positions++-- | Convert a buffer position to a character position+charIndexB :: Point -> BufferM Point+charIndexB p =+ fromIntegral <$> length <$> takeWhile (< p) <$> fst <$> unzip <$> indexedStreamB Forward 0++-- | Convert a character position to a buffer position+byteIndexB :: Point -> BufferM Point+byteIndexB p =+ fromIntegral <$> head <$> drop (fromIntegral p) <$> fst <$> unzip <$> indexedStreamB Forward 0++-- | Convert a character position region to a buffer position region+charRegionB :: Region -> BufferM Region+charRegionB r = do+ (xs,ys) <- span (< regionStart r) <$> fst <$> unzip <$> indexedStreamB Forward 0+ return (mkSizeRegion (fromIntegral (length xs)) (fromIntegral (length (takeWhile (< regionEnd r) ys))))++-- | Convert a buffer position region to position region+byteRegionB :: Region -> BufferM Region+byteRegionB r = do+ xs <- indexStreamRegionB r+ return $ mkRegion (head xs) (1 + last xs)++-- | Obtain an indexStreamRegion for the specified buff+indexStreamRegionB :: Region -> BufferM [Point]+indexStreamRegionB r =+ take (fromIntegral (regionSize r)) <$>+ drop (fromIntegral (regionStart r)) <$>+ fst <$> unzip <$> indexedStreamB Forward 0+
Yi/Buffer/Normal.hs view
@@ -9,8 +9,12 @@ -- * the textual units they work on -- * the direction towards which they operate (if applicable) -module Yi.Buffer.Normal (TextUnit(Character, Word, Line, ViWord, ViWORD, VLine,- Delimited, Document),+module Yi.Buffer.Normal (TextUnit(Character, Line, VLine, Document),+ leftBoundaryUnit, + unitWord,+ unitViWord,+ unitViWORD,+ unitDelimited, unitSentence, unitEmacsParagraph, unitParagraph, -- TextUnit is exported abstract intentionally: -- we'd like to move more units to the GenUnit format.@@ -25,24 +29,29 @@ deleteB, genMaybeMoveB, genMoveB, BoundarySide(..), genAtBoundaryB, checkPeekB+ , RegionStyle(..)+ , mkRegionOfStyleB+ , unitWiseRegion+ , extendRegionToBoundaries ) where import Yi.Buffer.Basic import Yi.Buffer.Misc import Yi.Buffer.Region import Data.Char+import Data.List (sort) import Control.Applicative import Control.Monad import Data.Typeable -- | Designate a given "unit" of text. data TextUnit = Character -- ^ a single character- | Word -- ^ a word as in use in Emacs (funamental mode)+ | Word -- ^ a word as in use in Emacs (fundamental mode) | ViWord -- ^ a word as in use in Vim | ViWORD -- ^ a WORD as in use in Vim | Line -- ^ a line of text (between newlines) | VLine -- ^ a "vertical" line of text (area of text between two characters at the same column number)- | Delimited Char Char -- ^ delimited on the left and right by given characters+ | Delimited Char Char Bool -- ^ delimited on the left and right by given characters, boolean argument tells if whether those are included. | Document -- ^ the whole document | GenUnit {genEnclosingUnit :: TextUnit, genUnitBoundary :: Direction -> BufferM Bool}@@ -50,6 +59,11 @@ -- idea to use GenUnit though. deriving Typeable +unitWord = Word+unitViWord = ViWord+unitViWORD = ViWORD+unitDelimited = Delimited+ isWordChar :: Char -> Bool isWordChar x = isAlphaNum x || x == '_' @@ -104,8 +118,10 @@ | otherwise = 3 _ -> True atBoundary Line direction = checkPeekB 0 [isNl] direction-atBoundary (Delimited c _) Backward = checkPeekB 0 [(== c)] Backward-atBoundary (Delimited _ c) Forward = (== c) <$> readB+atBoundary (Delimited c _ False) Backward = checkPeekB 0 [(== c)] Backward+atBoundary (Delimited _ c False) Forward = (== c) <$> readB+atBoundary (Delimited c _ True) Backward = checkPeekB (-1) [(== c)] Backward+atBoundary (Delimited _ c True) Forward = checkPeekB (0) [(== c)] Backward atBoundary (GenUnit _ atBound) dir = atBound dir enclosingUnit :: TextUnit -> TextUnit@@ -127,15 +143,19 @@ unitSentence :: TextUnit unitSentence = GenUnit unitEmacsParagraph $ \dir -> checkPeekB (if dir == Forward then -1 else 0) (mayReverse dir [isEndOfSentence, isSpace]) dir +-- | Unit that have its left and right boundaries at the left boundary of the argument unit.+leftBoundaryUnit :: TextUnit -> TextUnit+leftBoundaryUnit u = GenUnit Document $ (\_dir -> atBoundaryB u Backward)+ -- | @genAtBoundaryB u d s@ returns whether the point is at a given boundary @(d,s)@ . -- Boundary @(d,s)@ , taking Word as example, means: -- Word -- ^^ ^^ -- 12 34--- 1: (Backward,Outside)--- 2: (Backward,Inside)--- 3: (Forward,Inside)--- 4: (Forward,Outside)+-- 1: (Backward,OutsideBound)+-- 2: (Backward,InsideBound)+-- 3: (Forward,InsideBound)+-- 4: (Forward,OutsideBound) -- -- rules: -- genAtBoundaryB u Backward InsideBound = atBoundaryB u Backward@@ -283,4 +303,35 @@ readUnitB :: TextUnit -> BufferM String readUnitB = readRegionB <=< regionOfB +-- Region styles are relative to the buffer contents.+-- They likely should be considered a TextUnit.+data RegionStyle = LineWise+ | Inclusive+ | Exclusive+ deriving (Eq, Typeable, Show)++mkRegionOfStyleB :: Point -> Point -> RegionStyle -> BufferM Region+mkRegionOfStyleB start' stop' regionStyle =+ let [start, stop] = sort [start', stop']+ region = mkRegion start stop in+ case regionStyle of+ LineWise -> inclusiveRegionB =<< unitWiseRegion Line region+ Inclusive -> inclusiveRegionB region+ Exclusive -> return region++unitWiseRegion :: TextUnit -> Region -> BufferM Region+unitWiseRegion unit = extendRegionToBoundaries unit InsideBound OutsideBound++-- | Extend the given region to boundaries of the text unit.+-- For instance one can extend the selection to complete lines, or+-- paragraphs.+extendRegionToBoundaries :: TextUnit -> BoundarySide -> BoundarySide -> Region -> BufferM Region+extendRegionToBoundaries unit bs1 bs2 region = savingPointB $ do+ moveTo $ regionStart region+ genMaybeMoveB unit (Backward, bs1) Backward+ start <- pointB+ moveTo $ regionEnd region+ genMaybeMoveB unit (Forward, bs2) Forward+ stop <- pointB+ return $ mkRegion' (regionDirection region) start stop
Yi/Buffer/Region.hs view
@@ -9,6 +9,7 @@ , swapRegionsB , deleteRegionB , replaceRegionB+ , replaceRegionClever , readRegionB , mapRegionB , modifyRegionB@@ -29,9 +30,9 @@ winRegionB :: BufferM Region winRegionB = do w <- ask- Just (WinMarks f _ _ t) <- getMarks w- tospnt <- getMarkPointB f- bospnt <- getMarkPointB t+ Just ms <- getMarks w+ tospnt <- getMarkPointB (fromMark ms)+ bospnt <- getMarkPointB (toMark ms) return $ mkRegion tospnt bospnt -- | Delete an arbitrary part of the buffer@@ -43,11 +44,25 @@ readRegionB r = nelemsB' (regionEnd r ~- i) i where i = regionStart r +-- | Replace a region with a given string. replaceRegionB :: Region -> String -> BufferM () replaceRegionB r s = do deleteRegionB r insertNAt s (regionStart r) +-- | As 'replaceRegionB', but do a minimal edition instead of deleting the whole+-- region and inserting it back.+replaceRegionClever :: Region -> String -> BufferM ()+replaceRegionClever region text' = savingExcursionB $ do+ text <- readRegionB region+ let diffs = getGroupedDiff text text'+ moveTo (regionStart region)+ forM_ diffs $ \(d,str) -> do+ case d of+ F -> deleteN $ length str+ B -> rightN $ length str+ S -> insertN str+ mapRegionB :: Region -> (Char -> Char) -> BufferM () mapRegionB r f = do text <- readRegionB r@@ -62,6 +77,9 @@ replaceRegionB r' w0 replaceRegionB r w1 +-- Transform a replace into a modify.+replToMod replace = \transform region -> replace region =<< transform <$> readRegionB region+ -- | Modifies the given region according to the given -- string transformation function modifyRegionB :: (String -> String)@@ -69,21 +87,13 @@ -> Region -- ^ The region to modify -> BufferM ()-modifyRegionB transform region = replaceRegionB region =<< transform <$> readRegionB region+modifyRegionB = replToMod replaceRegionB + -- | As 'modifyRegionB', but do a minimal edition instead of deleting the whole -- region and inserting it back. modifyRegionClever :: (String -> [Char]) -> Region -> BufferM ()-modifyRegionClever transform region = savingExcursionB $ do- text <- readRegionB region- let text' = transform text- diffs = getGroupedDiff text text'- moveTo (regionStart region)- forM_ diffs $ \(d,str) -> do- case d of- F -> deleteN $ length str- B -> rightN $ length str- S -> insertN str+modifyRegionClever = replToMod replaceRegionClever -- | Extend the right bound of a region to include it. inclusiveRegionB :: Region -> BufferM Region@@ -94,4 +104,3 @@ where pointAfter p = pointAt $ do moveTo p rightB-
Yi/Buffer/Undo.hs view
@@ -99,12 +99,12 @@ isNotSavedFilePoint _ = True -- | This undoes one interaction step.-undoU :: URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))-undoU ur b = undoUntilInteractive [] (undoInteractive ur) b+undoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoU m ur b = undoUntilInteractive m [] (undoInteractive ur) b -- | This redoes one iteraction step.-redoU :: URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))-redoU = asRedo undoU+redoU :: Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+redoU m = asRedo (undoU m) -- | Prepare undo by moving one interaction point from undoes to redoes. undoInteractive :: URList -> URList@@ -122,18 +122,26 @@ -- | Repeatedly undo actions, storing away the inverse operations in the -- redo list.-undoUntilInteractive :: [Update] -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))-undoUntilInteractive xs ur@(URList cs rs) b = case cs of- [] -> (b, (ur, xs))- [SavedFilePoint] -> (b, (ur, xs)) -- Why this special case?- (InteractivePoint:_) -> (b, (ur, xs))- (SavedFilePoint:cs') ->- undoUntilInteractive xs (URList cs' (SavedFilePoint:rs)) b- (AtomicChange u:cs') -> - let ur' = (URList cs' (AtomicChange (reverseUpdateI u):rs))- b' = (applyUpdateWithMoveI u b)- (b'', (ur'', xs'')) = undoUntilInteractive xs ur' b'- in (b'', (ur'', u:xs''))+undoUntilInteractive :: Mark -> [Update] -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, [Update]))+undoUntilInteractive pointMark xs ur@(URList cs rs) b = case cs of+ [] -> (b, (ur, xs))+ [SavedFilePoint] -> (b, (ur, xs)) -- Why this special case?+ (InteractivePoint:_) -> (b, (ur, xs))+ (SavedFilePoint:cs') ->+ undoUntilInteractive pointMark xs (URList cs' (SavedFilePoint:rs)) b+ (AtomicChange u:cs') -> + let ur' = (URList cs' (AtomicChange (reverseUpdateI u):rs))+ b' = (applyUpdateWithMoveI u b)+ (b'', (ur'', xs'')) = undoUntilInteractive pointMark xs ur' b'+ in (b'', (ur'', u:xs''))+ where+ -- | Apply a /valid/ update and also move point in buffer to update position+ applyUpdateWithMoveI :: Update -> BufferImpl syntax -> BufferImpl syntax+ applyUpdateWithMoveI u = case updateDirection u of+ Forward -> apply . move+ Backward -> move . apply+ where move = modifyMarkBI pointMark (\v -> v {markPoint = updatePoint u})+ apply = applyUpdateI u -- | Run the undo-function @f@ on a swapped URList making it -- operate in a redo fashion instead of undo.
Yi/Completion.hs view
@@ -16,6 +16,7 @@ -- General completion -- | Return the longest common prefix of a set of strings.+-- -- > P(xs) === all (isPrefixOf (commonPrefix xs)) xs -- > length s > length (commonPrefix xs) --> not (all (isPrefixOf s) xs) commonPrefix :: [String] -> String
Yi/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures, RecursiveDo, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, RecursiveDo, Rank2Types #-} -- Copyright (c) Tuomo Valkonen 2004. -- Copyright (c) Don Stewart 2004-5. http://www.cse.unsw.edu.au/~dons@@ -40,7 +40,6 @@ -- * Misc , runAction- , withMode , withSyntax ) where@@ -57,6 +56,7 @@ import Yi.Keymap import Yi.Keymap.Keys import Yi.KillRing (krEndCmd)+import Yi.Style (errorStyle) import qualified Yi.Interact as I import Yi.Monad import qualified Yi.WindowSet as WS@@ -146,7 +146,7 @@ entryEvs <- withEditor $ getA pendingEventsA logPutStrLn $ "pending events: " ++ showEvs entryEvs (userActions,_p') <- withBuffer $ do- keymap <- withModeB modeKeymap+ keymap <- gets (withMode0 modeKeymap) p0 <- getA keymapProcessA let defKm = defaultKm $ yiConfig $ yi let freshP = I.mkAutomaton $ forever $ keymap $ defKm@@ -203,11 +203,15 @@ e2 = modifier buffersA (fmap clearUpdates) e1 UI.refresh (yiUi yi) e1 return var {yiEditor = e2}- where clearHighlight fb@FBuffer {pendingUpdates = us, highlightSelection = h} - = modifier highlightSelectionA (const (h && null us)) fb- -- if there were updates, then hide the selection.- clearUpdates fb = modifier pendingUpdatesA (const []) fb+ where + clearUpdates fb = modifier pendingUpdatesA (const []) fb+ clearHighlight fb =+ -- if there were updates, then hide the selection.+ let h = getter highlightSelectionA fb+ us = getter pendingUpdatesA fb+ in modifier highlightSelectionA (const (h && null us)) fb + -- | Suspend the program suspendEditor :: YiM ()@@ -251,7 +255,7 @@ -- | Show an error on the status line and log it. errorEditor :: String -> YiM ()-errorEditor s = do msgEditor ("error: " ++ s)+errorEditor s = do withEditor $ printStatus ("error: " ++ s, errorStyle) logPutStrLn $ "errorEditor: " ++ s -- | Close the current window.@@ -334,12 +338,6 @@ case mec of Nothing -> threadDelay (500*1000) >> waitForExit ph Just ec -> return (Right ec)--withMode :: (Show x, YiAction a x) => (forall syntax. Mode syntax -> a) -> YiM ()-withMode f = do- b <- withEditor Editor.getBuffer- act <- withBufferMode b f- runAction $ makeAction $ act withSyntax :: (Show x, YiAction a x) => (forall syntax. Mode syntax -> syntax -> a) -> YiM () withSyntax f = do
Yi/Editor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleContexts, StandaloneDeriving #-} -- Copyright (c) 2004-5, Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2007-8, JP Bernardy@@ -12,11 +12,13 @@ import Yi.Monad import Yi.Dynamic import Yi.KillRing+import Yi.Tag import Yi.Window+import Yi.Window import Yi.WindowSet (WindowSet) import qualified Yi.WindowSet as WS import Yi.Event (Event)-+import Yi.Style (StyleName, defaultStyle) import Prelude (map, filter, (!!), takeWhile, length, reverse, zip) import Yi.Prelude@@ -27,9 +29,13 @@ import qualified Data.DelayList as DelayList import qualified Data.Map as M import Data.Typeable+import System.FilePath (FilePath) import Control.Monad.RWS hiding (get, put) import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 +type Status = (String,StyleName)+type Statuses = DelayList.DelayList Status+ -- | The Editor state data Editor = Editor { bufferStack :: ![BufferRef] -- ^ Stack of all the buffers. Never empty;@@ -41,17 +47,32 @@ ,dynamic :: !(DynamicValues) -- ^ dynamic components - ,statusLines :: !(DelayList.DelayList String)+ ,statusLines :: !Statuses ,killring :: !Killring ,regex :: !(Maybe SearchExp) -- ^ most recent regex+ ,tagsFileList :: ![FilePath] -- ^ file path list for ctags+ ,tags :: !(Maybe TagTable) -- ^ table for ctags ,searchDirection :: !Direction ,pendingEvents :: ![Event] -- ^ Processed events that didn't yield any action yet. } deriving Typeable instance Binary Editor where- put (Editor bss bs supply ts _dv sl kr _re _dir _ev) = put bss >> put bs >> put supply >> put ts >> put sl >> put kr - get = Editor <$> get <*> get <*> get <*> get <*> pure emptyDV <*> get <*> get <*> pure Nothing <*> pure Forward <*> pure []+ put (Editor bss bs supply ts _dv _sl kr _re tfl _tt _dir _ev) = put bss >> put bs >> put supply >> put ts >> put kr >> put tfl+ get = do+ bss <- get+ bs <- get+ supply <- get+ ts <- get+ kr <- get+ tfl <- get+ return $ emptyEditor {bufferStack = bss,+ buffers = bs,+ refSupply = supply,+ tabs = ts,+ killring = kr,+ tagsFileList = tfl+ } windows :: Editor -> WindowSet Window windows editor =@@ -79,7 +100,7 @@ pendingEventsA :: Accessor Editor [Event] pendingEventsA = Accessor pendingEvents (\f e -> e {pendingEvents = f (pendingEvents e)}) -statusLinesA :: Accessor Editor (DelayList.DelayList String)+statusLinesA :: Accessor Editor Statuses statusLinesA = Accessor statusLines (\f e -> e {statusLines = f (statusLines e)}) @@ -107,6 +128,12 @@ regexA :: Accessor Editor (Maybe SearchExp) regexA = Accessor regex (\f e -> e{regex = f (regex e)}) +tagsA :: Accessor Editor (Maybe TagTable)+tagsA = Accessor tags (\f e -> e {tags = f (tags e)})++tagsFileListA :: Accessor Editor [FilePath]+tagsFileListA = Accessor tagsFileList (\f e -> e {tagsFileList = f (tagsFileList e)})+ searchDirectionA :: Accessor Editor Direction searchDirectionA = Accessor searchDirection (\f e -> e{searchDirection = f (searchDirection e)}) @@ -117,11 +144,13 @@ buffers = M.singleton (bkey buf) buf ,tabs = WS.new (WS.new win) ,bufferStack = [bkey buf]- ,refSupply = 2+ ,refSupply = 2 ,regex = Nothing+ ,tags = Nothing+ ,tagsFileList = ["tags"] ,searchDirection = Forward ,dynamic = M.empty- ,statusLines = DelayList.insert (maxBound, "") []+ ,statusLines = DelayList.insert (maxBound, ("", defaultStyle)) [] ,killring = krEmpty ,pendingEvents = [] }@@ -233,9 +262,11 @@ ------------------------------------------------------------------------ --- | Perform action with any given buffer+-- | Perform action with any given buffer, using the last window that was used for that buffer. withGivenBuffer0 :: BufferRef -> BufferM a -> EditorM a-withGivenBuffer0 k f = withGivenBufferAndWindow0 (dummyWindow k) k f+withGivenBuffer0 k f = do+ b <- gets (findBufferWith k)+ withGivenBufferAndWindow0 (lastActiveWindow b) k f -- | Perform action with any given buffer withGivenBufferAndWindow0 :: Window -> BufferRef -> BufferM a -> EditorM a@@ -273,27 +304,35 @@ b <- gets $ findBufferWith k insertBuffer b -- a bit of a hack. ---------------+-----------------------+-- Handling of status -- | Display a transient message printMsg :: String -> EditorM ()-printMsg = setTmpStatus 1+printMsg s = printStatus (s, defaultStyle) +printStatus :: Status -> EditorM ()+printStatus = setTmpStatus 1+ -- | Set the "background" status line -setStatus :: String -> EditorM ()+setStatus :: Status -> EditorM () setStatus = setTmpStatus maxBound -- | Clear the status line-msgClr :: EditorM ()-msgClr = setStatus ""+clrStatus :: EditorM ()+clrStatus = setStatus ("", defaultStyle) statusLine :: Editor -> String-statusLine = snd . head . statusLines+statusLine = fst . statusLineInfo -setTmpStatus :: Int -> String -> EditorM ()-setTmpStatus delay s = do+statusLineInfo :: Editor -> Status+statusLineInfo = snd . head . statusLines+++setTmpStatus :: Int -> Status -> EditorM ()+setTmpStatus delay (s,sty) = do modifyA statusLinesA $ DelayList.insert (delay, - takeWhile (/= '\n') s)+ (takeWhile (/= '\n') s,sty)) -- also show in the messages buffer, so we don't loose any message bs <- gets $ findBufferWithName "*messages*" b <- case bs of@@ -303,7 +342,7 @@ -- ------------------------------------------------------------------------ Register interface to killring.+-- kill-register (vim-style) interface to killring. -- | Put string into yank register setRegE :: String -> EditorM ()@@ -314,6 +353,23 @@ getRegE = getsA killringA krGet -- ---------------------------------------------------------------------+-- Direct access interface to TagTable.++-- | Set a new TagTable+setTags :: TagTable -> EditorM ()+setTags = setA tagsA . Just++-- | Reset the TagTable+resetTags :: EditorM ()+resetTags = setA tagsA Nothing++-- | Get the currently registered tag table+getTags :: EditorM (Maybe TagTable)+getTags = getA tagsA++++-- --------------------------------------------------------------------- -- | Dynamically-extensible state components. -- -- These hooks are used by keymaps to store values that result from@@ -421,6 +477,11 @@ findWindowWith k e = head $ concatMap (\win -> if (wkey win == k) then [win] else []) $ windows e +windowsOnBufferE :: BufferRef -> EditorM [Window]+windowsOnBufferE k = do+ e <- gets id+ return $ concatMap (concatMap (\win -> if (bufkey win == k) then [win] else [])) (tabs e)+ -- | Split the current window, opening a second window onto current buffer. -- TODO: unfold newWindowE here? splitE :: EditorM ()@@ -478,9 +539,10 @@ -- | Execute the argument in the context of an other window. Create -- one if necessary. The current window is re-focused after the -- argument has completed.-withOtherWindow :: MonadEditor m => m () -> m ()+withOtherWindow :: MonadEditor m => m a -> m a withOtherWindow f = do shiftOtherWindow- f+ x <- f liftEditor prevWinE+ return x
Yi/Eval.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} module Yi.Eval ( -- * Eval\/Interpretation@@ -83,6 +83,7 @@ mkAct = [ toDyn (makeAction :: BufferM () -> Action), toDyn (makeAction :: BufferM Bool -> Action),+ toDyn (makeAction :: BufferM Char -> Action), toDyn (makeAction :: BufferM Int -> Action), toDyn (makeAction :: BufferM String -> Action), toDyn (makeAction :: BufferM Region -> Action),@@ -98,6 +99,9 @@ toDyn (makeAction :: YiM BufferRef -> Action), toDyn (makeAction :: (String -> YiM ()) -> Action),++ toDyn (makeAction :: (String -> String -> BufferM ()) -> Action),+ toDyn (makeAction :: (Char -> BufferM ()) -> Action), toDyn (makeAction :: (BufferRef -> EditorM ()) -> Action)
Yi/Event.hs view
@@ -12,7 +12,7 @@ import Data.Monoid import Yi.Debug -data Modifier = MShift | MCtrl | MMeta+data Modifier = MShift | MCtrl | MMeta | MSuper deriving (Show,Eq,Ord) data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
Yi/File.hs view
@@ -1,6 +1,7 @@ module Yi.File ( -- * File-based actions+ viWrite, viWriteTo, fwriteE, -- :: YiM () fwriteBufferE, -- :: BufferM () fwriteAllE, -- :: YiM ()@@ -37,6 +38,27 @@ msgEditor "Can't revert, no file associated with buffer." return () +-- | 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 $ getA fileA+ case mf of+ Nothing -> errorEditor "no file name associate with buffer"+ Just f -> do+ bufInfo <- withBuffer bufInfoB+ let s = bufInfoFileName bufInfo+ fwriteE+ msgEditor $ show f ++ " " ++ show s ++ " written"++-- | Try to write to a named file in the manner of vi\/vim+viWriteTo :: String -> YiM ()+viWriteTo f = do+ bufInfo <- withBuffer bufInfoB+ let s = bufInfoFileName bufInfo+ fwriteToE f+ msgEditor $ show f++" "++show s ++ " written"+ -- | Write current buffer to disk, if this buffer is associated with a file fwriteE :: YiM () fwriteE = fwriteBufferE =<< withEditor getBuffer@@ -66,8 +88,8 @@ -- | Write all open buffers fwriteAllE :: YiM () fwriteAllE = - do buffers <- withEditor getBuffers- let modifiedBuffers = filter (not . isUnchangedBuffer) buffers+ do allBuffs <- withEditor getBuffers+ let modifiedBuffers = filter (not . isUnchangedBuffer) allBuffs mapM_ fwriteBufferE (fmap bkey modifiedBuffers) -- | Make a backup copy of file
Yi/History.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- Copyright (c) 2005,2007,2008 Jean-Philippe Bernardy
+ Yi/IReader.hs view
@@ -0,0 +1,100 @@+module Yi.IReader where++import Control.Monad.State+import Data.List+import System.Directory (getHomeDirectory)++import Yi.Keymap+import Yi.Prelude+import Yi.Buffer.Misc+import Yi.Buffer.Region+import Yi.Buffer.Normal+import Yi.Buffer.HighLevel+import qualified System.IO as IO+++type Article = String+type ArticleDB = [String]++-- | Get the first article in the list. We use the list to express relative priority;+-- the first is the most, the last least. We then just cycle through - everybody gets equal time.+getLatestArticle :: ArticleDB -> Article+getLatestArticle [] = ""+getLatestArticle adb = head adb++-- | We remove the old first article, and we stick it on the end of the+-- list using the presumably modified version.+updateSetLast :: ArticleDB -> Article -> ArticleDB+updateSetLast [] a = [a]+updateSetLast (_:bs) a = bs ++ [a]++-- | Insert a new article with top priority (that is, at the front of the list).+insertArticle :: ArticleDB -> Article -> ArticleDB+insertArticle = flip (:)++-- | Delete the first+deleteArticle :: ArticleDB -> Article -> ArticleDB+deleteArticle = flip delete++writeDB :: ArticleDB -> YiM ()+writeDB adb = io $ join $ liftM (flip writeFile $ show adb) $ dbLocation++readDB :: YiM ArticleDB+readDB = io $ rddb `catch` (\_ -> return (return []))+ where rddb = do db <- liftM readfile $ dbLocation+ liftM read db+ -- We need these for strict IO+ readfile :: FilePath -> IO String+ readfile f = IO.openFile f IO.ReadMode >>= hGetContents+ hGetContents :: IO.Handle -> IO.IO String+ hGetContents h = IO.hGetContents h >>= \s -> length s `seq` return s++dbLocation :: IO FilePath+dbLocation = getHomeDirectory >>= \home -> return (home ++ "/.yi/articles.db")++-- | Returns the database as it exists on the disk, and the current Yi buffer contents.+oldDbNewArticle :: YiM (ArticleDB, Article)+oldDbNewArticle = do olddb <- readDB+ newarticle <- withBuffer getBufferContents+ return (olddb, newarticle)++getBufferContents :: BufferM String+getBufferContents = readRegionB =<< regionOfB Document++-- | Given an 'ArticleDB', dump the scheduled article into the buffer (replacing previous contents).+setDisplayedArticle :: ArticleDB -> YiM ()+setDisplayedArticle newdb = do let nextarticle = getLatestArticle newdb+ withBuffer (replaceBufferContent nextarticle)+ withBuffer topB -- replaceBufferContents moves us+ -- to bottom?++-- | Go to next one. This ignores the buffer, but it doesn't remove anything from the database.+-- The ordering does change, however.+nextArticle :: YiM ()+nextArticle = do (oldb,_) <- oldDbNewArticle+ -- Ignore buffer, just set the first article last+ let newdb = updateSetLast oldb (getLatestArticle oldb)+ setDisplayedArticle newdb+ writeDB newdb++-- | Delete current article (the article as in the database), and go to next one.+deleteAndNextArticle :: YiM ()+deleteAndNextArticle = do ((_:ndb),_) <- oldDbNewArticle -- throw away changes, drop head+ setDisplayedArticle ndb+ writeDB ndb++-- | The main action. We fetch the old database, we fetch the modified article from the buffer,+-- then we call the function 'updateSetLast' which removes the first article and pushes our modified article+-- to the end of the list.+saveAndNextArticle :: YiM ()+saveAndNextArticle = do (oldb,newa) <- oldDbNewArticle+ let newdb = updateSetLast oldb newa+ setDisplayedArticle newdb+ writeDB newdb++-- | Assume the buffer is an entirely new article just imported this second, and save it.+-- We don't want to use 'updateSetLast' since that will erase an article.+saveAsNewArticle :: YiM ()+saveAsNewArticle = do (oldb,newa) <- oldDbNewArticle+ let newdb = insertArticle oldb newa+ writeDB newdb
Yi/IncrementalParse.hs view
@@ -1,293 +1,237 @@-{-# LANGUAGE EmptyDataDecls, ScopedTypeVariables #-} -- Copyright (c) JP Bernardy 2008-module Yi.IncrementalParse (Process, Void, - recoverWith, symbol, eof, runPolish,+{-# OPTIONS -fglasgow-exts #-}+module Yi.IncrementalParse (Process, + recoverWith, symbol, eof, lookNext, testNext, runPolish, + runP, profile, pushSyms, pushEof, evalR, P, AlexState (..), scanner) where import Yi.Lexer.Alex (AlexState (..)) import Yi.Prelude-import Prelude ()+import Prelude (Ordering(..)) import Yi.Syntax-import Data.List hiding (map)+import Data.List hiding (map, minimumBy) -{- ----------------------------------------+data a :< b -- Based on a mix between "Polish Parsers, Step by Step (Hughes and Swierstra)", - and "Parallel Parsing Processes (Claessen)"- - It's strongly advised to read the papers! :) -- The parser has "online" behaviour.-- This is a big advantage because we don't have to parse the whole file to- begin syntax highlight the beginning of it.--- Basic error correction+type P s a = Parser s a -- Based on Applicative functors.+-- | Parser specification+data Parser s a where+ Pure :: a -> Parser s a+ Appl :: Parser s (b -> a) -> Parser s b -> Parser s a - This is not as powerful as Monadic parsers, but easier to work with. This is- needed if we want to build the result lazily.+ Bind :: Parser s a -> (a -> Parser s b) -> Parser s b + Look :: Parser s a -> (s -> Parser s a) -> Parser s a+ Shif :: Parser s a -> Parser s a+ Empt :: Parser s a+ Disj :: Parser s a -> Parser s a -> Parser s a+ Yuck :: Parser s a -> Parser s a+ --------------------------------------------}+-- | Parser process+data Steps s a where+ Val :: a -> Steps s r -> Steps s (a :< r)+ App :: Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)+ Done :: Steps s ()+ Shift :: Steps s a -> Steps s a+ Sh' :: Steps s a -> Steps s a+ Fail :: Steps s a+ Sus :: Steps s a -> (s -> Steps s a) -> Steps s a+ Best :: Ordering -> Profile -> Steps s a -> Steps s a -> Steps s a+ Dislike :: Steps s a -> Steps s a +-- profile !! s = number of Dislikes found to do s Shifts+data Profile = PSusp | PFail | PRes Int | !Int :> Profile+ deriving Show -data Void+mapSucc :: Profile -> Profile+mapSucc PSusp = PSusp+mapSucc PFail = PFail+mapSucc (PRes x) = PRes (succ x) +mapSucc (x :> xs) = succ x :> mapSucc xs -type Process s a = Steps s a (Steps s Void Void)+-- Map lookahead to maximum dislike difference we accept. When looking much further,+-- we are more prone to discard smaller differences. It's essential that this drops below 0 when+-- its argument increases, so that we can discard things with dislikes using only+-- finite lookahead.+dislikeThreshold :: Int -> Int+dislikeThreshold n + | n < 5 = 0+ | otherwise = -1 -- we looked 5 tokens ahead, and still have no clue who is the best. Pick at random. --- | Our parsing processes.--- To understand the design of this data type it is important to consider the--- basic design goal: Our parser should return a (partial) result as soon as--- possible, that is, as soon as only one of all possible parses of an input--- can succeed. This also means we want to be able to return partial results.--- We therefore have to transform our parse tree into a linearized form that--- allows us to return parts of it as we parse them. Consider the following--- data type:------ > data BinTree = Node BinTree BinTree | Leaf Int--- > ex1 = Node (Leaf 1) (Node (Leaf 2) (Leaf 3))------ Provided we know the arity of each constructor, we can unambiguously--- represent @ex1@ (without using parentheses to resolve ambiguity) as:------ > Node Leaf 1 Node Leaf 2 Leaf 3------ This is simply a pre-order printing of the tree type and, in this case, is--- exactly how we defined @ex1@ without all the parentheses. It would,--- however, be unnecessarily complicated to keep track of the arity of each--- constructor, so we use a well-known trick: currying. Note, that the--- original definition of @ex1@ is actually a shorter notation for------ > ((Node $ (Leaf $ 1)) $ ((Node $ (Leaf $ 2)) $ (Leaf $ 3)))------ or as a tree--- --- > $--- > .-------------'----------------------.--- > $ $--- > .--'-------. .-------------'-------.--- > Node $ $ $--- > .--'-. .--'-------. .--'-.--- > Leaf 1 Node $ Leaf 3--- > .--'-.--- > Leaf 2------ where @$@ represents function application. We can print this tree in--- prefix-order:------ > ($) ($) Node ($) Leaf 1 ($) ($) Node ($) Leaf 2 ($) Leaf 3------ This consists of only two types of nodes -- values and applications -- but--- we can construct values of any (non-strict) Haskell data type with it.------ Unfortunately, it is a bit tricky to type those kinds of expressions in--- Haskell. [XXX: example; develop solution step by step; continuations]------ The parameter @r@ represents the type of the remainder of our expression.+-- | Compute the combination of two profiles, as well as which one is the best.+better :: Int -> Profile -> Profile -> (Ordering, Profile)+better _ PFail p = (GT, p) -- avoid failure+better _ p PFail = (LT, p)+better _ PSusp _ = (EQ, PSusp) -- could not decide before suspension => leave undecided.+better _ _ PSusp = (EQ, PSusp)+better _ (PRes x) (PRes y) = if x <= y then (LT, PRes x) else (GT, PRes y) -- two results, just pick the best.+better lk xs@(PRes x) (y:>ys) = if x == 0 || y-x > dislikeThreshold lk then (LT, xs) else min x y +> better (lk+1) xs ys+better lk (y:>ys) xs@(PRes x) = if x == 0 || y-x > dislikeThreshold lk then (GT, xs) else min x y +> better (lk+1) ys xs+better lk (x:>xs) (y:>ys)+ | x == 0 && y == 0 = rec -- never drop things with no error: this ensures to find a correct parse if it exists.+ | x - y > threshold = (GT, y:>ys)+ | y - x > threshold = (LT, x:>xs) -- if at any point something is too disliked, drop it.+ | otherwise = rec+ where threshold = dislikeThreshold lk+ rec = min x y +> better (lk + 1) xs ys --- TODO: Replace 'Doc:' by ^ when haddock supports GADTs-data Steps s a r where- -- These constructors describe the tree of values, as above- Val :: a -> Steps s b r -> Steps s a (Steps s b r)- -- Doc: The process that returns the value of type @a@ which is followed by a parser returning a value of type @b@.- App :: Steps s (b -> a) (Steps s b r) -> Steps s a r- -- Doc: Takes a process that returns a function @f@ of type @b -> a@ and is- -- followed by a process returning a value @x@ of type @b@. The resulting- -- process will return the result of applying the function @f@ to @x@.- Stop :: Steps s Void Void- - -- These constructors describe the parser state- Shift :: Steps s a r -> Steps s a r- Done :: Steps s a r -> Steps s a r- -- Doc: The parser that signals success. The argument is the continuation.- Fails :: Steps s a r- -- Doc: The parser that signals failure.- Dislike :: Steps s a r -> Steps s a r+(+>) :: Int -> (t, Profile) -> (t, Profile)+x +> ~(ordering, xs) = (ordering, x :> xs) - Suspend :: ([s] -> Steps s a r) -> Steps s a r- -- Doc: A suspension of the parser (this is the part borrowed from- -- Parallel Parsing Processes) The parameter to suspend's- -- continuation is a whole chunk of text; [] represents the- -- end of the input- +profile :: Steps s r -> Profile+profile (Val _ p) = profile p+profile (App p) = profile p+profile (Shift p) = 0 :> profile p+profile (Done) = PRes 0 -- success with zero dislikes+profile (Fail) = PFail+profile (Dislike p) = mapSucc (profile p)+profile (Sus _ _) = PSusp+profile (Best _ pr _ _) = pr+profile (Sh' _) = error "Sh' should be hidden by Sus" -instance Show (Steps s a r) where+instance Show (Steps s r) where show (Val _ p) = "v" ++ show p show (App p) = "*" ++ show p- show (Stop) = "1"+ show (Done) = "1" show (Shift p) = ">" ++ show p- show (Done p) = "!" ++ show p+ show (Sh' p) = "'" ++ show p show (Dislike p) = "?" ++ show p- show (Fails) = "0"- show (Suspend _) = "..."---- data F a b where--- Snoc :: F a b -> (b -> c) -> F a c--- Nil :: F a b--- --- data S s a r where--- S :: F a b -> Steps s a r -> S s a r+ show (Fail) = "0"+ show (Sus _ _) = "..."+ show (Best _ _ p q) = "(" ++ show p ++ ")" ++ show q --- | Right-eval a fully defined process (ie. one that has no Suspend)+-- | Right-eval a fully defined process (ie. one that has no Sus) -- Returns value and continuation.-evalR :: Steps s a r -> (a, r)+evalR :: Steps s (a :< r) -> (a, Steps s r) evalR (Val a r) = (a,r) evalR (App s) = let (f, s') = evalR s (x, s'') = evalR s' in (f x, s'')-evalR Stop = error "evalR: Can't create values of type Void" evalR (Shift v) = evalR v-evalR (Done v) = evalR v-evalR (Dislike v) = -- trace "Yuck!" $ - evalR v-evalR (Fails) = error "evalR: No parse!"-evalR (Suspend _) = error "evalR: Not fully evaluated!"-+evalR (Dislike v) = evalR v+evalR (Fail) = error "evalR: No parse!"+evalR (Sus _ _) = error "evalR: Not fully evaluated!"+evalR (Sh' _) = error "evalR: Sh' should be hidden by Sus"+evalR (Best choice _ p q) = case choice of+ LT -> evalR p+ GT -> evalR q+ EQ -> error $ "evalR: Ambiguous parse: " ++ show p ++ " ~~~ " ++ show q -- | Pre-compute a left-prefix of some steps (as far as possible)-evalL :: Steps s a r -> Steps s a r+evalL :: Steps s r -> Steps s r evalL (Shift p) = evalL p evalL (Dislike p) = evalL p evalL (Val x r) = Val x (evalL r) evalL (App f) = case evalL f of (Val a (Val b r)) -> Val (a b) r- (Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r) r -> App r+evalL x@(Best choice _ p q) = case choice of+ LT -> evalL p+ GT -> evalL q+ EQ -> x -- don't know where to go: don't speculate on evaluating either branch. evalL x = x ---- | Push a chunk of symbols or eof in the process. This forces some suspensions.-push :: Maybe [s] -> Steps s a r -> Steps s a r-push (Just []) p = p -- nothing more left to push-push ss p = case p of- (Suspend f) -> case ss of- Nothing -> f []- Just ss' -> f ss'- (Dislike p') -> Dislike (push ss p')- (Shift p') -> Shift (push ss p')- (Done p') -> Done (push ss p')- (Val x p') -> Val x (push ss p')- (App p') -> App (push ss p')- Stop -> Stop- Fails -> Fails---- | Push some symbols.-pushSyms :: [s] -> Steps s a r -> Steps s a r-pushSyms x = push (Just x)---- | Push eof-pushEof :: Steps s a r -> Steps s a r-pushEof = push Nothing---- | A parser. (This is actually a parsing process segment)-newtype P s a = P (forall b r. Steps s b r -> Steps s a (Steps s b r))--instance Functor (P s) where- fmap f x = pure f <*> x--instance Applicative (P s) where- P f <*> P x = P (App . f . x)- pure x = P (Val x)--instance Alternative (P s) where- empty = P $ \_fut -> Fails- P a <|> P b = P $ \fut -> best (a fut) (b fut)------ | Advance in the result steps, pushing results in the continuation.--- (Must return one of: Done, Shift, Fail)-getProgress :: (Steps s a r -> Steps s b t) -> Steps s a r -> Steps s b t-getProgress f (Val a s) = getProgress (f . Val a) s-getProgress f (App s) = getProgress (f . App) s--- getProgress f Stop = f Stop-getProgress f (Done p) = Done (f p)-getProgress f (Shift p) = Shift (f p)-getProgress f (Dislike p) = Dislike (f p)-getProgress _ (Fails) = Fails-getProgress _ Stop = error "getProgress: try to enter void"-getProgress f (Suspend p) = Suspend (\input -> f (p input))----best :: Steps x a s -> Steps x a s -> Steps x a s---l `best` r | trace ("best: "++show (l,r)) False = undefined-Suspend f `best` Suspend g = Suspend (\input -> f input `best` g input)--Fails `best` p = p-p `best` Fails = p--Dislike a `best` b = bestD a b-a `best` Dislike b = bestD b a--Done a `best` Done _ = Done a -- error "ambiguous grammar"- -- There are sometimes many ways to fix an error. Pick the 1st one.-Done a `best` _ = Done a-_ `best` Done a = Done a--Shift v `best` Shift w = Shift (v `best` w)--p `best` q = getProgress id p `best` getProgress id q+instance Functor (Parser s) where+ fmap f = (pure f <*>) +instance Applicative (Parser s) where+ (<*>) = Appl+ pure = Pure --- as best, but lhs is disliked.-bestD :: Steps x a s -> Steps x a s -> Steps x a s+instance Alternative (Parser s) where+ (<|>) = Disj+ empty = Empt -Suspend f `bestD` Suspend g = Suspend (\input -> f input `bestD` g input)+instance Monad (Parser s) where+ (>>=) = Bind+ return = pure -Fails `bestD` p = p-p `bestD` Fails = Dislike p+toQ :: Parser s a -> forall h r. ((h,a) -> Steps s r) -> (h -> Steps s r)+toQ (Look a f) = \k h -> Sus (toQ a k h) (\s -> toQ (f s) k h)+toQ (p `Appl` q) = \k -> toQ p $ toQ q $ \((h, b2a), b) -> k (h, b2a b)+toQ (Pure a) = \k h -> k (h, a)+toQ (Disj p q) = \k h -> iBest (toQ p k h) (toQ q k h)+toQ (Bind p a2q) = \k -> (toQ p) (\(h,a) -> toQ (a2q a) k h)+toQ Empt = \_k _h -> Fail+toQ (Yuck p) = \k h -> Dislike $ toQ p k h+toQ (Shif p) = \k h -> Sh' $ toQ p k h -a `bestD` Dislike b = Dislike (best a b) -- back to equilibrium (prefer to do this, hence 1st case)-Dislike _ `bestD` b = b -- disliked twice: forget it.+toP :: Parser s a -> forall r. (Steps s r) -> (Steps s (a :< r))+toP (Look a f) = \fut -> Sus (toP a fut) (\s -> toP (f s) fut)+toP (Appl f x) = App . toP f . toP x+toP (Pure x) = Val x+toP Empt = \_fut -> Fail+toP (Disj a b) = \fut -> iBest (toP a fut) (toP b fut)+toP (Bind p a2q) = \fut -> (toQ p) (\(_,a) -> (toP (a2q a)) fut) ()+toP (Yuck p) = Dislike . toP p +toP (Shif p) = Sh' . toP p -Done _ `bestD` Done a = Done a -- we prefer rhs in this case-Done a `bestD` _ = Dislike (Done a)-_ `bestD` Done a = Done a+-- | Intelligent, caching best.+iBest :: Steps s a -> Steps s a -> Steps s a+iBest p q = let ~(choice, pr) = better 0 (profile p) (profile q) in Best choice pr p q -Shift v `bestD` Shift w = Shift (v `bestD` w)-_ `bestD` Shift w = Shift w -- prefer shifting than keeping a disliked possibility forever+symbol :: forall s. (s -> Bool) -> Parser s s+symbol f = Look empty $ \s -> if f s then (Shif $ pure s) else empty +eof :: forall s. Parser s ()+eof = Look (pure ()) (const empty) -p `bestD` q = getProgress id p `bestD` getProgress id q+-- | Push a chunk of symbols or eof in the process. This forces some suspensions.+feed :: Maybe [s] -> Steps s r -> Steps s r+feed (Just []) p = p -- nothing more left to feed+feed ss p = case p of+ (Sus nil cons) -> case ss of+ Just [] -> p -- no more info, stop feeding+ Nothing -> feed Nothing nil -- finish+ Just (s:_) -> feed ss (cons s)+ (Shift p') -> Shift (feed ss p')+ (Sh' p') -> Shift (feed (fmap (drop 1) ss) p')+ (Dislike p') -> Dislike (feed ss p')+ (Val x p') -> Val x (feed ss p')+ (App p') -> App (feed ss p')+ Done -> Done+ Fail -> Fail+ Best _ _ p' q' -> iBest (feed ss p') (feed ss q')+ -- TODO: it would be nice to be able to reuse the profile here. +-- | Push some symbols.+pushSyms :: [s] -> Steps s r -> Steps s r+pushSyms x = feed (Just x) +-- | Push eof+pushEof :: Steps s r -> Steps s r+pushEof = feed Nothing -runP :: forall t t1.- P t t1 -> Steps t t1 (Steps t Void Void)-runP (P p) = p (Done Stop)+runP :: forall s a. P s a -> Process s a+runP p = toP p Done -- | Run a parser. runPolish :: forall s a. P s a -> [s] -> a runPolish p input = fst $ evalR $ pushEof $ pushSyms input $ runP p --- | Parse a symbol-symbol :: (s -> Bool) -> P s s-symbol f = P $ \fut -> Suspend $ \input ->- case input of- [] -> Fails -- This is the eof!- (s:ss) -> if f s then push (Just ss) (Shift (Val s (fut)))- else Fails+testNext :: (Maybe s -> Bool) -> P s ()+testNext f = Look (if f Nothing then ok else empty) (\s -> + if (f $ Just s) then ok else empty)+ where ok = pure () --- | Parse the eof-eof :: P s ()-eof = P $ \fut -> Suspend $ \input ->- case input of- [] -> Val () fut- _ -> Fails+lookNext :: P s (Maybe s)+lookNext = Look (pure Nothing) (\s -> pure (Just s)) + + -- | Parse the same thing as the argument, but will be used only as -- backup. ie, it will be used only if disjuncted with a failing -- parser. recoverWith :: forall s a. P s a -> P s a-recoverWith (P p) = P (Dislike . p)+recoverWith = Yuck -----------------------------------------------------+type Process token result = Steps token (result :< ()) type State st token result = (st, Process token result) scanner :: forall st token result. P token result -> Scanner st token -> Scanner (State st token result) result@@ -307,5 +251,4 @@ updateState0 curState toks@((st,tok):rest) = ((st, curState), result) : updateState0 nextState rest where nextState = evalL $ pushSyms [tok] $ curState result = fst $ evalR $ pushEof $ pushSyms (fmap snd toks) $ curState-
Yi/Interpreter.hs view
@@ -12,7 +12,7 @@ import Control.Applicative import Text.ParserCombinators.Parsec.Token import qualified Text.ParserCombinators.Parsec as Parsec-import Text.ParserCombinators.Parsec (GenParser, chainl1)+import Text.ParserCombinators.Parsec (chainl1) import qualified Data.Map as M import Data.Traversable import Prelude hiding (mapM)@@ -72,8 +72,9 @@ rename env = mapM renameOne where renameOne (AVar v) = do- val <- M.lookup v env- return val+ case M.lookup v env of+ Just x -> Right x+ Nothing -> Left $ v ++ " not found in the environment" renameOne (AChar x) = box x renameOne (AString x) = box x renameOne (AInt x) = box x
Yi/Keymap.hs view
@@ -88,9 +88,6 @@ write :: (I.MonadInteract m Action ev, YiAction a x, Show x) => a -> m () write x = I.write (makeAction x) -withBufferMode :: BufferRef -> (forall syntax. Mode syntax -> a) -> YiM a-withBufferMode b f = withGivenBuffer b $ withModeB f- -------------------------------- -- Uninteresting glue code
Yi/Keymap/Cua.hs view
@@ -1,24 +1,32 @@ -- Copyright (c) 2008 Jean-Philippe Bernardy -module Yi.Keymap.Cua (keymap) where+module Yi.Keymap.Cua (keymap, portableKeymap) where import Prelude hiding (error) import Yi.Core import Yi.File import Yi.Keymap.Emacs.Utils import Yi.Misc+import Yi.Rectangle+import Yi.String keymap :: Keymap-keymap = selfInsertKeymap <|> move <|> select <|> other+keymap = portableKeymap ctrl +-- | Introduce a keymap that is compatible with both windows and osx,+-- by parameterising the event modifier required for commands+portableKeymap :: (Event -> Event) -> Keymap+portableKeymap cmd = selfInsertKeymap <|> move <|> select <|> rect <|> other cmd+ selfInsertKeymap :: Keymap selfInsertKeymap = do c <- printableChar write (withBuffer0 $ replaceSel [c]) -setMark :: BufferM ()-setMark = do+setMark :: Bool -> BufferM ()+setMark b = do isSet <- getA highlightSelectionA+ setA rectangleSelectionA b when (not isSet) $ do setA highlightSelectionA True pointB >>= setSelectionMarkPointB@@ -35,20 +43,46 @@ when (length s == 1) (adjBlock 1) insertN s +deleteSel :: BufferM () -> YiM ()+deleteSel act = do+ haveSelection <- withBuffer $ getA highlightSelectionA+ if haveSelection+ then withEditor del+ else withBuffer (adjBlock (-1) >> act)+ cut, del, copy, paste :: EditorM () cut = copy >> del-del = withBuffer0 (deleteRegionB =<< getSelectRegionB)-copy = setRegE =<< withBuffer0 (readRegionB =<< getSelectRegionB)-paste = withBuffer0 . replaceSel =<< getRegE+del = do+ asRect <- withBuffer0 $ getA rectangleSelectionA+ if asRect+ then killRectangle+ else withBuffer0 $ deleteRegionB =<< getSelectRegionB+copy = do+ (setRegE =<<) $ withBuffer0 $ do+ asRect <- getA rectangleSelectionA+ if not asRect+ then readRegionB =<< getSelectRegionB+ else do+ (reg, l, r) <- getRectangle+ unlines' <$> fmap (take (r-l) . drop l) <$> lines' <$> readRegionB reg+paste = do+ asRect <- withBuffer0 (getA rectangleSelectionA)+ if asRect+ then yankRectangle+ else withBuffer0 . replaceSel =<< getRegE moveKeys :: [(Event, BufferM ())] moveKeys = [ (spec KHome , maybeMoveB Line Backward), (spec KEnd , maybeMoveB Line Forward),+ (super (spec KRight) , maybeMoveB Line Forward),+ (super (spec KLeft ) , maybeMoveB Line Backward), (ctrl (spec KHome) , maybeMoveB Document Backward), (ctrl (spec KEnd) , maybeMoveB Document Forward),- (ctrl (spec KRight) , moveB Word Forward),- (ctrl (spec KLeft ) , moveB Word Backward),+ (super (spec KUp) , maybeMoveB Document Backward),+ (super (spec KDown) , maybeMoveB Document Forward),+ (ctrl (spec KRight) , moveB unitWord Forward),+ (ctrl (spec KLeft ) , moveB unitWord Backward), (spec KUp , moveB VLine Backward), (spec KDown , moveB VLine Forward), (spec KRight , moveB Character Forward),@@ -56,28 +90,29 @@ ] -move, select, other :: Keymap+move, select, rect :: Keymap+other :: (Event -> Event) -> Keymap -move = choice [ k ?>>! unsetMark >> a | (k,a) <- moveKeys]-select = choice [shift k ?>>! setMark >> a | (k,a) <- moveKeys]-other = choice [- spec KBS ?>>! adjBlock (-1) >> bdeleteB,- spec KDel ?>>! do- haveSelection <- withBuffer $ getA highlightSelectionA- if haveSelection- then withEditor del- else withBuffer (adjBlock (-1) >> deleteN 1),- spec KEnter ?>>! insertB '\n',- ctrl (char 'q') ?>>! askQuitEditor,- ctrl (char 'f') ?>> isearchKeymap Forward,- ctrl (char 'x') ?>>! cut,- ctrl (char 'c') ?>>! copy,- ctrl (char 'v') ?>>! paste,- ctrl (spec KIns) ?>>! copy,+move = choice [ k ?>>! unsetMark >> a | (k,a) <- moveKeys]+select = choice [ shift k ?>>! setMark False >> a | (k,a) <- moveKeys]+rect = choice [meta (shift k) ?>>! setMark True >> a | (k,a) <- moveKeys]+other cmd = choice [+ spec KBS ?>>! deleteSel bdeleteB,+ spec KDel ?>>! deleteSel (deleteN 1),+ spec KEnter ?>>! replaceSel "\n",+ cmd (char 'q') ?>>! askQuitEditor,+ cmd (char 'f') ?>> isearchKeymap Forward,+ cmd (char 'x') ?>>! cut,+ cmd (char 'c') ?>>! copy,+ cmd (char 'v') ?>>! paste,+ cmd (spec KIns) ?>>! copy, shift (spec KIns) ?>>! paste,- ctrl (char 'z') ?>>! undoB,- ctrl (char 'y') ?>>! redoB,- ctrl (char 's') ?>>! fwriteE,- ctrl (char 'o') ?>>! findFile+ cmd (char 'z') ?>>! undoB,+ cmd (char 'y') ?>>! redoB,+ cmd (char 's') ?>>! fwriteE,+ cmd (char 'o') ?>>! findFile,+ cmd (char '/') ?>>! withModeB modeToggleCommentSelection,+ cmd (char ']') ?>>! autoIndentB IncreaseOnly,+ cmd (char '[') ?>>! autoIndentB DecreaseOnly ]
Yi/Keymap/Emacs.hs view
@@ -20,6 +20,7 @@ , evalRegionE , executeExtendedCommandE , findFile+ , promptFile , insertNextC , isearchKeymap , killBufferE@@ -29,9 +30,9 @@ , scrollUpE , cabalConfigureE , switchBufferE- , withMinibuffer , askSaveEditor , argToInt+ , promptTag ) import Data.Maybe import Data.Char@@ -131,6 +132,8 @@ -- All the key-bindings which are preceded by a 'C-x' , ctrlCh 'x' ?>> ctrlX++ , ctrlCh 'c' ?>> ctrlC -- All The key-bindings of the form M-c where 'c' is some character. , metaCh 'v' ?>>! scrollUpE univArg@@ -150,10 +153,11 @@ , metaCh 'l' ?>>! (repeatingArg lowercaseWordB) , metaCh 'q' ?>>! (withSyntax modePrettify) , metaCh 'u' ?>>! (repeatingArg uppercaseWordB)- , metaCh 't' ?>>! (repeatingArg $ transposeB Word Forward)+ , metaCh 't' ?>>! (repeatingArg $ transposeB unitWord Forward) , metaCh 'w' ?>>! killRingSaveE , metaCh 'x' ?>>! executeExtendedCommandE , metaCh 'y' ?>>! yankPopE+ , metaCh '.' ?>>! promptTag -- Other meta key-bindings , meta (spec KBS) ?>>! (repeatingArg bkillWordB)@@ -170,6 +174,7 @@ withIntArg :: YiAction (m ()) () => (Int -> m ()) -> YiM () withIntArg cmd = withUnivArg $ \arg -> cmd (fromMaybe 1 arg) + ctrlC = choice [ ctrlCh 'c' ?>>! withModeB modeToggleCommentSelection ] rectangleFuntions = choice [char 'o' ?>>! openRectangle,@@ -188,10 +193,7 @@ , ctrlCh 'c' ?>>! askQuitEditor , ctrlCh 'f' ?>>! findFile , ctrlCh 's' ?>>! fwriteE- , ctrlCh 'w' ?>>! (withMinibuffer "Write file:"- (matchingFileNames Nothing)- fwriteToE- )+ , ctrlCh 'w' ?>>! promptFile "Write file:" fwriteToE , ctrlCh 'x' ?>>! (exchangePointAndMarkB >> setA highlightSelectionA True) , char 'b' ?>>! switchBufferE
Yi/Keymap/Emacs/KillRing.hs view
@@ -43,9 +43,9 @@ -- | M-w killRingSaveE :: EditorM () killRingSaveE = do (r, text) <- withBuffer0 $ do- setA highlightSelectionA False r <- getSelectRegionB text <- readRegionB r+ setA highlightSelectionA False return (r,text) killringPut (regionDirection r) text -- | M-y@@ -54,7 +54,7 @@ yankPopE :: EditorM () yankPopE = do kr <- getA killringA- withBuffer0 (deleteRegionB =<< getSelectRegionB)+ withBuffer0 (deleteRegionB =<< getRawestSelectRegionB) setA killringA $ let ring = krContents kr in kr {krContents = tail ring ++ [head ring]} yankE
Yi/Keymap/Emacs/Utils.hs view
@@ -29,15 +29,18 @@ , killBufferE , insertNextC , findFile+ , promptFile+ , promptTag ) where {- Standard Library Module Imports -} -import Prelude ()+import Prelude (take) import Data.List ((\\))+import Data.Maybe (maybe) import System.FriendlyPath-import System.FilePath (addTrailingPathSeparator)+import System.FilePath (addTrailingPathSeparator, takeDirectory, takeFileName, (</>)) import System.Directory ( doesDirectoryExist )@@ -54,6 +57,7 @@ import Yi.MiniBuffer import Yi.Misc import Yi.Regex+import Yi.Tag import Yi.Search import Yi.Window {- End of Module Imports -}@@ -162,8 +166,8 @@ ] isearchKeymap :: Direction -> Keymap-isearchKeymap direction = - do write $ isearchInitE direction+isearchKeymap dir = + do write $ isearchInitE dir many searchKeymap choice [ ctrl (char 'g') ?>>! isearchCancelE , oneOf [ctrl (char 'm'), spec KEnter] >>! isearchFinishE@@ -183,7 +187,7 @@ oneOf [char 'y', char ' '] >>! qrReplaceOne win b re replaceWith, oneOf [char 'q', ctrl (char 'g')] >>! qrFinish ]- Just re = makeSearchOptsM [] replaceWhat+ Right re = makeSearchOptsM [] replaceWhat withEditor $ do setRegexE re spawnMinibufferE@@ -235,15 +239,20 @@ Just <$> ((ctrlCh 'u' ?>> (read <$> some (digit id) <|> pure 4)) <|> (read <$> (some tt))) <|> pure Nothing- +-- | Generic emacs prompt file action. Takes a @prompt and a continuation @act+-- and prompts the user with file hints+promptFile :: String -> (String -> YiM ()) -> YiM ()+promptFile prompt act = do maybePath <- withBuffer $ getA fileA+ startPath <- addTrailingPathSeparator <$> (liftIO $ canonicalizePath' =<< getFolder maybePath)+ -- TODO: Just call withMinibuffer+ withMinibufferGen startPath (findFileHint startPath) prompt (simpleComplete $ matchingFileNames (Just startPath)) act++ -- | Open a file using the minibuffer. We have to set up some stuff to allow hints -- and auto-completion. findFile :: YiM ()-findFile = do maybePath <- withBuffer $ getA fileA- startPath <- addTrailingPathSeparator <$> (liftIO $ canonicalizePath' =<< getFolder maybePath)- -- TODO: Just call withMinibuffer- withMinibufferGen startPath (findFileHint startPath) "find file:" (simpleComplete $ matchingFileNames (Just startPath)) $ \filename -> do+findFile = promptFile "find file:" $ \filename -> do msgEditor $ "loading " ++ filename fnewE filename @@ -286,3 +295,59 @@ killBufferE :: YiM () killBufferE = withMinibuffer "kill buffer:" matchingBufferNames $ askCloseBuffer++-- | Shortcut to use a default list when a blank list is given.+-- Used for default values to emacs queries+maybeList :: [a] -> [a] -> [a]+maybeList def [] = def+maybeList _ ls = ls++--------------------------------------------------+-- TAGS - See Yi.Tag for more info++-- | Prompt the user to give a tag and then jump to that tag+promptTag :: YiM ()+promptTag = do+ -- default tag is where the buffer is on+ defaultTag <- withBuffer $ readUnitB unitWord+ -- if we have tags use them to generate hints+ tagTable <- withEditor getTags+ -- Hints are expensive - only lazily generate 10+ let hinter = return . show . take 10 . maybe fail hintTags tagTable+ -- Completions are super-cheap. Go wild+ let completer = return . maybe id completeTag tagTable+ withMinibufferGen "" hinter ("Find tag: (default " ++ defaultTag ++ ")") completer $+ -- if the string is "" use the defaultTag+ gotoTag . maybeList defaultTag++-- | Opens the file that contains @tag@. Uses the global tag table and prompts+-- the user to open one if it does not exist+gotoTag :: Tag -> YiM ()+gotoTag tag =+ visitTagTable $ \tagTable ->+ case lookupTag tag tagTable of+ Nothing -> fail $ "No tags containing " ++ tag+ Just (filename, line) -> do+ fnewE $ filename+ withBuffer $ gotoLn line+ return ()++-- | Call continuation @act@ with the TagTable. Uses the global table+-- and prompts the user if it doesn't exist+visitTagTable :: (TagTable -> YiM ()) -> YiM ()+visitTagTable act = do+ posTagTable <- withEditor getTags+ -- does the tagtable exist?+ case posTagTable of+ Just tagTable -> act tagTable+ Nothing ->+ promptFile ("Visit tags table: (default tags)") $ \path -> do+ -- default emacs behavior, append tags+ let filename = maybeList "tags" $ takeFileName path+ tagTable <- io $ importTagTable $+ takeDirectory path </> filename+ withEditor $ setTags tagTable+ act tagTable++resetTagTable :: YiM ()+resetTagTable = withEditor resetTags
Yi/Keymap/Keys.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- Copyright (c) 2008 Jean-Philippe Bernardy -- | Combinators for building keymaps.@@ -6,7 +7,7 @@ ( module Yi.Event, module Yi.Interact,- printableChar, charOf, shift, meta, ctrl, spec, char, (>>!), (?>>), (?>>!),+ printableChar, charOf, shift, meta, ctrl, super, spec, char, (>>!), (?>>), (?>>!), ctrlCh, metaCh, pString ) where@@ -35,7 +36,7 @@ do Event (KASCII c) [] <- eventBetween (modifier $ char l) (modifier $ char h) return c -shift,ctrl,meta :: Event -> Event+shift,ctrl,meta,super :: Event -> Event shift (Event (KASCII c) ms) | isAlpha c = Event (KASCII (toUpper c)) ms | otherwise = error "shift: unhandled event" shift (Event k ms) = Event k $ nub $ sort (MShift:ms)@@ -43,6 +44,8 @@ ctrl (Event k ms) = Event k $ nub $ sort (MCtrl:ms) meta (Event k ms) = Event k $ nub $ sort (MMeta:ms)++super (Event k ms) = Event k $ nub $ sort (MSuper:ms) char :: Char -> Event char '\t' = Event KTab []
Yi/Keymap/Vim.hs view
@@ -8,17 +8,18 @@ viWrite, defKeymap, ModeMap(..),- mkKeymap) where+ mkKeymap,+ beginIns) where import Prelude (maybe, length, filter, map, drop, break, uncurry) import Data.Char-import Data.List (sort, nub, take)+import Data.List (nub, take, words) import Data.Prototype import Numeric (showHex, showOct) import System.IO (readFile)+import System.Posix.Files (fileExist) -import Control.Exception ( ioErrors, try, evaluate ) import Control.Monad.State hiding (mapM_, mapM) import {-# source #-} Yi.Boot@@ -27,29 +28,38 @@ import Yi.Eval (execEditorAction) import Yi.File import Yi.History-import Yi.Misc (matchingFileNames,adjBlock,adjIndent)-import Yi.String (dropSpace)+import Yi.Misc (matchingFileNames,adjBlock,adjIndent,cabalRun)+import Yi.String (dropSpace,split) import Yi.MiniBuffer import Yi.Search+import Yi.Style import Yi.TextCompletion+import Yi.Tag (Tag,TagTable,lookupTag,importTagTable)+import Yi.Window (bufkey) -- -- What's missing?--- fancier :s//+-- ESC should leave from the visual mode+-- fancier :s// ==> missing /c, ... -- '.'+-- @:+-- g8+-- 8g8+-- :sh[ell]+-- :!! -- movement parameterised \> \<+-- motion operators [motion.txt]: !, =, >, <+-- C-y in input mode+-- C-v: visual block mode+-- Support for marks+-- C-o and C-i -- -- --------------------------------------------------------------------- type VimMode = Keymap -data RegionStyle = LineWise- | Inclusive- | Exclusive- deriving (Eq, Typeable, Show)- data ViMove = Move TextUnit Direction | MaybeMove TextUnit Direction | GenMove TextUnit (Direction, BoundarySide) Direction@@ -89,22 +99,15 @@ -- | Top level consists of simple commands that take a count arg, -- the replace cmd, which consumes one char of input, and commands -- that switch modes.- def_top_level = choice [cmd_eval,cmd_move,cmd2other,cmd_op]-- -- | Leave a mode. This always has priority over catch-all actions inside the mode.- leave :: VimMode- leave = oneOf [spec KEsc, ctrl $ char 'c'] >> adjustPriority (-1) >> (write msgClr)-- -- | Insert mode is either insertion actions, or the meta (\ESC) action- ins_mode :: VimMode- ins_mode = write (setStatus "-- INSERT --") >> many (ins_char <|> kwd_mode) >> leave-- beginIns :: (Show x, YiAction a x) => a -> I Event Action ()- beginIns a = write a >> ins_mode+ def_top_level = do write clrStatus+ -- if the keymap "crashed" we restart here+ -- so we clear the status line to indicate whatever mode we were in+ -- has been left+ choice [cmd_eval,cmd_move,cmd2other,cmd_op] -- | Replace mode is like insert, except it performs writes, not inserts rep_mode :: VimMode- rep_mode = write (setStatus "-- REPLACE --") >> many rep_char >> leave+ rep_mode = write (setStatus ("-- REPLACE --", defaultStyle)) >> many rep_char >> leave -- | Reset the selection style to a character-wise mode 'SelectionStyle Character'. resetSelectStyle :: BufferM ()@@ -115,12 +118,12 @@ vis_mode selectionStyle = do write (setVisibleSelection True >> pointB >>= setSelectionMarkPointB) core_vis_mode selectionStyle- write (msgClr >> withBuffer0 (setVisibleSelection False) >> withBuffer0 resetSelectStyle)+ write (clrStatus >> withBuffer0 (setVisibleSelection False) >> withBuffer0 resetSelectStyle) core_vis_mode :: SelectionStyle -> VimMode core_vis_mode selectionStyle = do write $ do withBuffer0 $ setDynamicB $ selectionStyle- setStatus $ msg selectionStyle+ setStatus $ (msg selectionStyle, defaultStyle) many (cmd_move <|> select_any_unit (withBuffer0 . (\r -> resetSelectStyle >> extendSelectRegionB r >> leftB))) (vis_single selectionStyle <|| vis_multi)@@ -207,10 +210,10 @@ ,(char '|', \i -> SeqMove viMoveToSol (Replicate (CharMove Forward) (i-1))) -- words- ,(char 'w', Replicate $ GenMove ViWord (Backward,InsideBound) Forward)- ,(char 'W', Replicate $ GenMove ViWORD (Backward,InsideBound) Forward)- ,(char 'b', Replicate $ Move ViWord Backward)- ,(char 'B', Replicate $ Move ViWORD Backward)+ ,(char 'w', Replicate $ GenMove unitViWord (Backward,InsideBound) Forward)+ ,(char 'W', Replicate $ GenMove unitViWORD (Backward,InsideBound) Forward)+ ,(char 'b', Replicate $ Move unitViWord Backward)+ ,(char 'B', Replicate $ Move unitViWORD Backward) -- text ,(char '{', Replicate $ Move unitEmacsParagraph Backward) ,(char '}', Replicate $ Move unitEmacsParagraph Forward)@@ -238,23 +241,23 @@ [(char '$', eol) ,(spec KEnd, eol) -- words- ,(char 'e', Replicate $ GenMove ViWord (Forward, InsideBound) Forward)- ,(char 'E', Replicate $ GenMove ViWORD (Forward, InsideBound) Forward)]+ ,(char 'e', Replicate $ GenMove unitViWord (Forward, InsideBound) Forward)+ ,(char 'E', Replicate $ GenMove unitViWORD (Forward, InsideBound) Forward)] where eol = Replicate $ viMoveToEol -- | movement *multi-chars* commands (with inclusive cut/yank semantics) moveCmdS_inclusive :: [(String, (Int -> ViMove))] moveCmdS_inclusive =- [("ge", Replicate $ GenMove ViWord (Forward, InsideBound) Backward)- ,("gE", Replicate $ GenMove ViWORD (Forward, InsideBound) Backward)+ [("ge", Replicate $ GenMove unitViWord (Forward, InsideBound) Backward)+ ,("gE", Replicate $ GenMove unitViWORD (Forward, InsideBound) Backward) ,("g_", const $ ArbMove lastNonSpaceB)] regionOfViMove :: ViMove -> RegionStyle -> BufferM Region regionOfViMove move regionStyle =- join $ regionFromTo <$> pointB- <*> (savingPointB (viMove move >> pointB))- <*> pure regionStyle+ join $ mkRegionOfStyleB <$> pointB+ <*> (savingPointB (viMove move >> pointB))+ <*> pure regionStyle viMove :: ViMove -> BufferM () viMove NoMove = return ()@@ -317,18 +320,48 @@ choice $ [c ?>>! action i | (c,action) <- singleCmdFM ] ++ [events evs >>! action i | (evs, action) <- multiCmdFM ] ++- [char 'r' ?>> textChar >>= write . writeN . replicate i+ [char 'r' ?>> textChar >>= write . savingPointB . writeN . replicate i ,pString "gt" >>! nextTabE ,pString "gT" >>! previousTabE] - -- TODO: escape the current word- -- at word bounds: search for \<word\>+ -- TODO: add word bounds: search for \<word\> searchCurrentWord :: Direction -> EditorM () searchCurrentWord dir = do- w <- withBuffer0 $ readRegionB =<< regionOfNonEmptyB ViWord- viSearch w [] dir+ w <- withBuffer0 $ readRegionB =<< regionOfNonEmptyB unitViWord+ viSearch w [QuoteRegex] dir + gotoTag :: Tag -> YiM ()+ gotoTag tag =+ visitTagTable $ \tagTable ->+ case lookupTag tag tagTable of+ Nothing -> fail $ "No tags containing " ++ tag+ Just (filename, line) -> do+ fnewE $ filename+ withBuffer $ gotoLn line+ return ()++ -- | Call continuation @act@ with the TagTable. Uses the global table+ -- and prompts the user if it doesn't exist+ visitTagTable :: (TagTable -> YiM ()) -> YiM ()+ visitTagTable act = do+ posTagTable <- withEditor getTags+ -- does the tagtable exist?+ case posTagTable of+ Just tagTable -> act tagTable+ Nothing -> do fps <- withEditor $ getA tagsFileListA -- withBuffer0 $ tagsFileList <$> getDynamicB+ efps <- io $ filterM fileExist fps+ when (null efps) $ fail ("No existing tags file among: " ++ show fps)+ tagTable <- io $ importTagTable (head efps)+ withEditor $ setTags tagTable+ act tagTable++ gotoTagCurrentWord :: YiM ()+ gotoTagCurrentWord = gotoTag =<< withEditor (withBuffer0 (readRegionB =<< regionOfNonEmptyB unitViWord))++ setTagsFileList :: String -> EditorM ()+ setTagsFileList fps = resetTags >> setA tagsFileListA (split "," fps)+ -- | Parse any character that can be inserted in the text. textChar :: KeymapM Char textChar = do@@ -339,7 +372,7 @@ continueSearching fdir = do m <- getRegexE dir <- fdir <$> getA searchDirectionA - printMsg $ direction '?' '/' dir : maybe "" fst m+ printMsg $ directionElim dir '?' '/' : maybe "" fst m viSearch "" [] dir -- | cmd mode commands@@ -349,15 +382,18 @@ singleCmdFM = [(ctrl $ char 'b', withBuffer . upScreensB) -- vim does (firstNonSpaceB;moveXorSol) ,(ctrl $ char 'f', withBuffer . downScreensB)+ ,(ctrl $ char 'u', withBuffer . scrollByB (negate . (`div` 2)))+ ,(ctrl $ char 'd', withBuffer . scrollByB (`div` 2)) ,(ctrl $ char 'g', const viFileInfo) ,(ctrl $ char 'l', const refreshEditor) ,(ctrl $ char 'r', withBuffer . flip replicateM_ redoB) ,(ctrl $ char 'z', const suspendEditor)+ ,(ctrl $ char ']', const gotoTagCurrentWord) ,(char 'D', withEditor . cut Exclusive . (Replicate $ Move Line Forward)) ,(char 'J', const (withBuffer (moveToEol >> deleteN 1))) -- the "\n" ,(char 'Y', \n -> withEditor $ do let move = Replicate (Move Line Forward) n- region <- withBuffer0 $ regionOfViMove move Inclusive+ region <- withBuffer0 $ regionOfViMove move LineWise yankRegion LineWise region ) ,(char 'U', withBuffer . flip replicateM_ undoB) -- NB not correct@@ -463,60 +499,42 @@ , (('g':), 'w', const $ withBuffer0 . savingPointB . fillRegion) ] - char2unit :: [(Char, TextUnit)]+ -- Argument of the 2nd component is whether the unit is outer.+ toOuter u True = leftBoundaryUnit u+ toOuter u False = u++ char2unit :: [(Char, Bool -> TextUnit)] char2unit =- [('w', ViWord)- ,('W', ViWORD)- ,('p', unitEmacsParagraph)- ,('s', unitSentence)- ,('"', Delimited '"' '"')- ,('`', Delimited '`' '`')- ,('\'', Delimited '\'' '\'')- ,('(', Delimited '(' ')')- ,(')', Delimited '(' ')')- ,('b', Delimited '(' ')')- ,('{', Delimited '{' '}')- ,('}', Delimited '{' '}')- ,('B', Delimited '{' '}')- ,('<', Delimited '<' '>')- ,('>', Delimited '<' '>')+ [('w', toOuter unitViWord)+ ,('W', toOuter unitViWORD)+ ,('p', toOuter unitEmacsParagraph)+ ,('s', toOuter unitSentence)+ ,('"', unitDelimited '"' '"')+ ,('`', unitDelimited '`' '`')+ ,('\'', unitDelimited '\'' '\'')+ ,('(', unitDelimited '(' ')')+ ,(')', unitDelimited '(' ')')+ ,('b', unitDelimited '(' ')')+ ,('{', unitDelimited '{' '}')+ ,('}', unitDelimited '{' '}')+ ,('B', unitDelimited '{' '}')+ ,('<', unitDelimited '<' '>')+ ,('>', unitDelimited '<' '>') ] - -- NOTE,TODO: Form some units (like words) one should- -- not select more than the current line- select_a_unit :: TextUnit -> BufferM Region- select_a_unit (Delimited cStart cStop) = savingPointB $ do- start <- untilB ((==cStart) <$> readB) leftB >> pointB- rightB- stop <- untilB ((==cStop) <$> readB) rightB >> rightB >> pointB- return $ mkRegion start stop- select_a_unit unit = savingPointB $ do- start <- genMaybeMoveB unit (Backward,InsideBound) Backward >> pointB- stop <- genMoveB unit (Backward,InsideBound) Forward >> pointB- return $ mkRegion start stop- select_any_unit :: (MonadInteract m Action Event) => (Region -> EditorM ()) -> m ()- select_any_unit f =- choice [ x- | (c, unit) <- char2unit,- x <- [ char 'i' ?>> (char c ?>> write (f =<< withBuffer0 (regionOfNonEmptyB unit))), -- inner unit- char 'a' ?>> (char c ?>> write (f =<< withBuffer0 (select_a_unit unit))) ] ]-- regionFromTo :: Point -> Point -> RegionStyle -> BufferM Region- regionFromTo start' stop' regionStyle =- let [start, stop] = sort [start', stop']- region = mkRegion start stop in- case regionStyle of- LineWise -> inclusiveRegionB =<< unitWiseRegion Line region- Inclusive -> inclusiveRegionB region- Exclusive -> return region+ select_any_unit f = do + outer <- (char 'a' ?>> pure True) <|> (char 'i' ?>> pure False)+ choice [ char c ?>> write (f =<< withBuffer0 (regionOfNonEmptyB $ unit outer))+ | (c, unit) <- char2unit]+ regionOfSelection :: BufferM (RegionStyle, Region) regionOfSelection = do regionStyle <- selection2regionStyle <$> getDynamicB- region <- join $ regionFromTo <$> getSelectionMarkPointB- <*> pointB- <*> pure regionStyle+ region <- join $ mkRegionOfStyleB <$> getSelectionMarkPointB+ <*> pointB+ <*> pure regionStyle return (regionStyle, region) yankRegion :: RegionStyle -> Region -> EditorM ()@@ -559,7 +577,7 @@ selectionStyle <- getDynamicB start <- getSelectionMarkPointB stop <- pointB- region <- regionFromTo start stop $ selection2regionStyle $ selectionStyle+ region <- mkRegionOfStyleB start stop $ selection2regionStyle $ selectionStyle moveTo $ regionStart region deleteRegionB region insertN txt@@ -611,7 +629,7 @@ char 'x' ?>>! cutSelection, char 'd' ?>>! cutSelection, char 'p' ?>>! pasteOverSelection,- char 'c' ?>> beginIns (cutSelection >> withBuffer0 (setVisibleSelection False))]+ char 'c' ?>> beginIns self (cutSelection >> withBuffer0 (setVisibleSelection False))] -- | These also switch mode, as all visual commands do, but these are@@ -650,29 +668,29 @@ char 'v' ?>> vis_mode (SelectionStyle Character), char 'V' ?>> vis_mode (SelectionStyle Line), char 'R' ?>> rep_mode,- char 'i' ?>> ins_mode,- char 'I' ?>> beginIns moveToSol,- char 'a' ?>> beginIns $ moveXorEol 1,- char 'A' ?>> beginIns moveToEol,- char 'o' ?>> beginIns $ moveToEol >> insertB '\n',- char 'O' ?>> beginIns $ moveToSol >> insertB '\n' >> lineUp,+ char 'i' ?>> ins_mode self,+ char 'I' ?>> beginIns self firstNonSpaceB,+ char 'a' ?>> beginIns self $ moveXorEol 1,+ char 'A' ?>> beginIns self moveToEol,+ char 'o' ?>> beginIns self $ moveToEol >> insertB '\n',+ char 'O' ?>> beginIns self $ moveToSol >> insertB '\n' >> lineUp, char 'c' ?>> changeCmds,- char 'C' ?>> beginIns $ cut Exclusive viMoveToEol, -- alias of "c$"- char 'S' ?>> beginIns $ withBuffer0 moveToSol >> cut Exclusive viMoveToEol, -- non-linewise alias of "cc"- char 's' ?>> beginIns $ cut Exclusive (CharMove Forward), -- non-linewise alias of "cl"+ char 'C' ?>> beginIns self $ cut Exclusive viMoveToEol, -- alias of "c$"+ char 'S' ?>> beginIns self $ withBuffer0 moveToSol >> cut Exclusive viMoveToEol, -- non-linewise alias of "cc"+ char 's' ?>> beginIns self $ cut Exclusive (CharMove Forward), -- non-linewise alias of "cl" char '/' ?>>! ex_mode "/", char '?' ?>>! ex_mode "?", leave,- spec KIns ?>> ins_mode]+ spec KIns ?>> ins_mode self] changeCmds :: I Event Action () changeCmds = adjustPriority (-1) >>- ((char 'w' ?>> change NoMove Exclusive (GenMove ViWord (Forward, OutsideBound) Forward)) <|>- (char 'W' ?>> change NoMove Exclusive (GenMove ViWORD (Forward, OutsideBound) Forward))) <|>+ ((char 'w' ?>> change NoMove Exclusive (GenMove unitViWord (Forward, OutsideBound) Forward)) <|>+ (char 'W' ?>> change NoMove Exclusive (GenMove unitViWORD (Forward, OutsideBound) Forward))) <|> (char 'c' ?>> change viMoveToSol LineWise viMoveToEol) <|> (uncurry (change NoMove) =<< gen_cmd_move) <|>- (select_any_unit (cutRegion Exclusive) >> ins_mode) -- this correct while the RegionStyle is not LineWise+ (select_any_unit (cutRegion Exclusive) >> ins_mode self) -- this correct while the RegionStyle is not LineWise change :: ViMove -> RegionStyle -> ViMove -> I Event Action () change preMove regionStyle move = do@@ -680,7 +698,7 @@ withBuffer0 $ viMove preMove cut regionStyle move when (regionStyle == LineWise) $ withBuffer0 (insertB '\n' >> leftB)- ins_mode+ ins_mode self ins_rep_char :: VimMode ins_rep_char = choice [spec KPageUp ?>>! upScreenB,@@ -694,7 +712,7 @@ spec KDel ?>>! (adjBlock (-1) >> deleteB Character Forward), spec KEnter ?>>! insertB '\n', spec KTab ?>>! insertTabB,- (ctrl $ char 'w') ?>>! cut Exclusive (GenMove ViWord (Backward,InsideBound) Backward)]+ (ctrl $ char 'w') ?>>! cut Exclusive (GenMove unitViWord (Backward,InsideBound) Backward)] -- -- Some ideas for a better insert mode are contained in:@@ -705,18 +723,9 @@ -- which suggest that movement commands be added to insert mode, along -- with delete. --- ins_char :: VimMode- ins_char = v_ins_char self def_ins_char = (spec KBS ?>>! adjBlock (-1) >> deleteB Character Backward)- <|> ins_rep_char- <|| (textChar >>= write . (adjBlock 1 >>) . insertB)-- -- --------------------- -- | Keyword- kwd_mode :: VimMode- kwd_mode = some ((ctrl $ char 'n') ?>> (write wordComplete)) >> deprioritize >> (write resetComplete)- -- 'adjustPriority' is there to lift the ambiguity between "continuing" completion- -- and resetting it (restarting at the 1st completion).+ <|> ins_rep_char+ <|| (textChar >>= write . (adjBlock 1 >>) . insertB) -- --------------------------------------------------------------------- -- | vim replace mode@@ -770,9 +779,16 @@ 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 ('c':'a':'b':'a':'l':' ':s) = cabalComplete s ex_complete ('y':'i':' ':s) = exSimpleComplete (\_->getAllNamesInScope) s- ex_complete _ = return ""+ ex_complete s = catchAllComplete s + catchAllComplete = exSimpleComplete $ const $ return $ map (++ " ") $ words+ "e edit r read tabe b buffer bd bd! bdelete bdelete! yi cabal"+ cabalComplete = exSimpleComplete $ const $ return $ cabalCmds+ cabalCmds = words "configure install list update upgrade fetch upload check sdist" +++ words "report build copy haddock clean hscolour register test help"+ historyStart spawnMinibufferE prompt (const $ ex_process) return ()@@ -808,46 +824,80 @@ [] -> return () where- isWorthlessB = gets (\b -> isUnchangedBuffer b || file b == Nothing)+ {- safeQuitWindow implements the commands in vim equivalent to :q.+ - Closes the current window unless the current window is the last window on a + - modified buffer that is not considered "worthless".+ -}+ safeQuitWindow = do+ nw <- withBuffer needsAWindowB+ ws <- withEditor $ getA currentWindowA >>= windowsOnBufferE . bufkey+ if 1 == length ws && nw + then errorEditor "No write since last change (add ! to override)"+ else closeWindow+ + needsAWindowB = do+ isWorthless <- gets (\b -> file b == Nothing)+ canClose <- isUnchangedB+ if isWorthless || canClose then return False else return True+ + {- quitWindow implements the commands in vim equivalent to :q!+ - Closes the current window regardless of whether the window is on a modified+ - buffer or not. + - TODO: Does not quit the editor if there are modified hidden buffers.+ - + - Corey - Vim appears to abandon any changes to the current buffer if the window being + - closed is the last window on the buffer. The, now unmodified, buffer is still around + - and can be switched to using :b. I think this is odd and prefer the modified buffer+ - sticking around. + -}+ quitWindow = closeWindow+ + {- safeQuitAllWindows implements the commands in vim equivalent to :qa!+ - Exits the editor unless there is a modified buffer that is not worthless.+ -}+ safeQuitAllWindows = do+ bs <- mapM (\b -> withEditor (withGivenBuffer0 b needsAWindowB) >>= return . (,) b) =<< readEditor bufferStack+ -- Vim only shows the first modified buffer in the error.+ case find snd bs of+ Nothing -> quitEditor+ Just (b, _) -> do+ bufferName <- withEditor $ withGivenBuffer0 b $ gets name+ errorEditor $ "No write since last change for buffer " + ++ show bufferName+ ++ " (add ! to override)"+ whenUnchanged mu f = do u <- mu if u then f else errorEditor "No write since last change (add ! to override)"- quitB = whenUnchanged (withBuffer isWorthlessB) closeWindow - quitNoW = do bufs <- withEditor $ do closeBufferE ""- bufs <- gets bufferStack- mapM (\x -> withGivenBuffer0 x isWorthlessB) bufs- whenUnchanged (return $ all id bufs) quitEditor-- quitall = withAllBuffers quitB wquitall = withAllBuffers viWrite >> quitEditor bdelete = whenUnchanged (withBuffer isUnchangedB) . withEditor . closeBufferE bdeleteNoW = withEditor . closeBufferE - fn "" = withEditor msgClr+ -- fn maps from the text entered on the command line to a YiM () implementing the + -- command.+ fn "" = withEditor clrStatus - fn s@(c:_) | isDigit c = do- e <- liftIO $ try $ evaluate $ read s- case e of Left _ -> errorEditor $ "The " ++show s++ " command is unknown."- Right lineNum -> withBuffer (gotoLn lineNum) >> return ()+ fn s | all isDigit s = do let lineNum = read s+ withBuffer (gotoLn lineNum) >> return () fn "w" = viWrite fn ('w':' ':f) = viWriteTo $ dropSpace 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" = safeQuitAllWindows+ fn "qal" = safeQuitAllWindows+ fn "qall" = safeQuitAllWindows+ fn "quita" = safeQuitAllWindows+ fn "quital" = safeQuitAllWindows+ fn "quitall" = safeQuitAllWindows+ fn "q" = safeQuitWindow+ fn "qu" = safeQuitWindow+ fn "qui" = safeQuitWindow+ fn "quit" = safeQuitWindow+ fn "q!" = quitWindow+ fn "qu!" = quitWindow+ fn "qui!" = quitWindow+ fn "quit!" = quitWindow fn "qa!" = quitEditor fn "quita!" = quitEditor fn "quital!" = quitEditor@@ -874,6 +924,7 @@ fn ('r':' ':f) = withBuffer . insertN =<< io (readFile f) fn ('r':'e':'a':'d':' ':f) = withBuffer . insertN =<< io (readFile f) -- fn ('s':'e':'t':' ':'f':'t':'=':ft) = withBuffer $ setSyntaxB $ highlighters M.! ft+ fn ('s':'e':'t':' ':'t':'a':'g':'s':'=':fps) = withEditor $ setTagsFileList fps fn ('n':'e':'w':' ':f) = withEditor splitE >> fnewE f fn ('s':'/':cs) = withEditor $ viSub cs Line fn ('%':'s':'/':cs) = withEditor $ viSub cs Document@@ -890,6 +941,8 @@ fn ('b':'d':'e':'l':'e':'t':'e':'!':' ':f) = bdeleteNoW f -- TODO: bd[!] [N] + fn ('t':'a':'g':' ':t) = gotoTag t+ -- send just this line through external command /fn/ fn ('.':'!':f) = do ln <- withBuffer readLnB@@ -917,6 +970,7 @@ fn "st" = suspendEditor fn "stop" = suspendEditor + fn ('c':'a':'b':'a':'l':' ':s) = cabalRun s1 (const $ return ()) (drop 1 s2) where (s1, s2) = break (==' ') s fn ('y':'i':' ':s) = execEditorAction s fn "tabnew" = withEditor newTabE fn ('t':'a':'b':'e':' ':f) = do withEditor newTabE@@ -967,27 +1021,7 @@ PatternNotFound -> printMsg "Pattern not found" SearchWrapped -> printMsg "Search wrapped" --- | 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 $ getA fileA- 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 ++ " written"- catchJustE ioErrors (fwriteE >> msg) (msgEditor . show) --- | Try to write to a named file in the manner of vi\/vim-viWriteTo :: String -> YiM ()-viWriteTo f = do- bufInfo <- withBuffer bufInfoB- let s = bufInfoFileName bufInfo- let msg = msgEditor $ show f++" "++show s ++ " written"- catchJustE ioErrors (fwriteToE f >> msg) (msgEditor . show)- -- | Try to do a substitution viSub :: String -> TextUnit -> EditorM () viSub cs unit = do@@ -1004,5 +1038,24 @@ where do_single p r g = do s <- searchAndRepUnit p r g unit- if not s then fail ("Pattern not found: "++p) else msgClr+ if not s then fail ("Pattern not found: "++p) else clrStatus++-- | Leave a mode. This always has priority over catch-all actions inside the mode.+leave :: VimMode+leave = oneOf [spec KEsc, ctrl $ char 'c'] >> adjustPriority (-1) >> (write clrStatus)++-- | Insert mode is either insertion actions, or the meta (\ESC) action+ins_mode :: ModeMap -> VimMode+ins_mode self = write (setStatus ("-- INSERT --", defaultStyle)) >> many (v_ins_char self <|> kwd_mode) >> leave++beginIns :: (Show x, YiAction a x) => ModeMap -> a -> I Event Action ()+beginIns self a = write a >> ins_mode self++-- --------------------+-- | Keyword+kwd_mode :: VimMode+kwd_mode = some ((ctrl $ char 'n') ?>> (write wordComplete)) >> deprioritize >> (write resetComplete)+-- 'adjustPriority' is there to lift the ambiguity between "continuing" completion+-- and resetting it (restarting at the 1st completion).+
Yi/Lexer/Alex.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE Rank2Types #-} module Yi.Lexer.Alex ( alexGetChar, alexInputPrevChar, unfoldLexer, lexScanner, alexCollectChar,@@ -116,6 +116,7 @@ ofs -> case scanRun src (ofs - 1) of -- FIXME: if this is a non-ascii char the ofs. will be wrong. -- However, since the only thing that matters (for now) is 'is the previous char a new line', we don't really care.+ -- (this is to support ^,$ in regexes) [] -> [] ((_,ch):rest) -> unfoldLexer l (st, (ch, rest)) }
+ Yi/Lexer/GNUMake.x view
@@ -0,0 +1,63 @@+-- -*- haskell -*- +-- Lexer for Makefiles with consideration of GNU extensions +-- This is based off the syntax as described in the GNU Make manual:+-- http://www.gnu.org/software/make/manual/make.html+--+{+{-# OPTIONS -w #-}+module Yi.Lexer.GNUMake+ ( initState, alexScanToken ) +where+import Yi.Lexer.Alex+import Yi.Style+ ( Style ( .. )+ , StyleName+ )+import qualified Yi.Style as Style+}++make :-++<0>+{+ -- All lines that start with a \t are passed to the shell.+ -- This includes # characters that might be in the shell code! Those indicate comments *only* if+ -- the shell interpretting the code would consider it a comment. Wack huh?+ -- See 3.1+ ^\t.*+ { c Style.makeFileAction }+ \#+ { m (\_ -> InComment) Style.commentStyle }+ \n+ { c Style.defaultStyle }+ .+ { c Style.defaultStyle }+}++<comment>+{+ -- Comments can be continued to the next line with a trailing slash.+ -- See 3.1+ \\[.\n]+ { c Style.commentStyle }+ \n+ { m (\_ -> TopLevel) Style.defaultStyle }+ .+ { c Style.commentStyle }+}++{+data HlState = + TopLevel + | InComment++stateToInit TopLevel = 0+stateToInit InComment = comment++initState :: HlState+initState = TopLevel++type Token = StyleName+#include "alex.hsinc"+}+
Yi/Lexer/Haskell.x view
@@ -1,4 +1,4 @@--- -*- haskell -*- +-- -*- haskell -*- -- -- Lexical syntax for illiterate Haskell 98. --@@ -38,7 +38,7 @@ $symchar = [$symbol \:] $nl = [\n\r] -@reservedid = +@reservedid = as|case|class|data|default|else|hiding|if| import|in|infix|infixl|infixr|instance|newtype| qualified|then|type|family|forall|foreign|export|dynamic|@@ -99,38 +99,38 @@ -- it's also possible that we have just finishing a line, -- people sometimes do this for example when breaking up paragraphs -- in a long comment.- "--"$nl { c $ Comment Line }+ "--"$nl { c $ Comment Line } - "{-" { m (subtract 1) $ Comment Open }+ "{-" { m (subtract 1) $ Comment Open } - ^"#".* { c $ CppDirective }- $special { cs $ \(c:_) -> Special c }- "deriving" { c (Reserved Deriving) }- @reservedid { c (Reserved Other) }- "module" { c (Reserved Module) }- "where" { c (Reserved Where) }- @layoutReservedId { c (Reserved OtherLayout) }- `@qual @varid` { c Operator }- `@qual @conid` { c ConsOperator }- @qual @varid { c VarIdent }- @qual @conid { c ConsIdent }+ ^"#".* { c $ CppDirective }+ $special { cs $ \(c:_) -> Special c }+ "deriving" { c (Reserved Deriving) }+ @reservedid { c (Reserved Other) }+ "module" { c (Reserved Module) }+ "where" { c (Reserved Where) }+ @layoutReservedId { c (Reserved OtherLayout) }+ `@qual @varid` { c Operator }+ `@qual @conid` { c ConsOperator }+ @qual @varid { c VarIdent }+ @qual @conid { c ConsIdent } - "|" { c (ReservedOp Pipe) }- "=" { c (ReservedOp Equal) }- @reservedop { c (ReservedOp OtherOp) }- @qual @varsym { c Operator }- @qual @consym { c ConsOperator }+ "|" { c (ReservedOp Pipe) }+ "=" { c (ReservedOp Equal) }+ @reservedop { c (ReservedOp OtherOp) }+ @qual @varsym { c Operator }+ @qual @consym { c ConsOperator } - @decimal - | 0[oO] @octal- | 0[xX] @hexadecimal { c Number }+ @decimal+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c Number } - @decimal \. @decimal @exponent?- | @decimal @exponent { c Number }+ @decimal \. @decimal @exponent?+ | @decimal @exponent { c Number } - \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }- \" @string* \" { c StringTok }- . { c Unrecognized }+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }+ \" @string* \" { c StringTok }+ . { c Unrecognized } } {
Yi/Lexer/LiterateHaskell.x view
@@ -12,6 +12,7 @@ {-# OPTIONS -w #-} module Yi.Lexer.LiterateHaskell ( initState, alexScanToken ) where import Yi.Lexer.Alex+import Yi.Lexer.Haskell hiding (initState, alexScanToken) import Yi.Style } @@ -39,16 +40,21 @@ $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|family|forall|mdo|foreign|export|dynamic|+ as|case|class|data|default|else|hiding|if|+ import|in|infix|infixl|infixr|instance|newtype|+ qualified|then|type|family|forall|foreign|export|dynamic| safe|threadsafe|unsafe|stdcall|ccall|dotnet +@layoutReservedId =+ of|let|do|mdo++ @reservedop = ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" @varid = $small $idchar* @conid = $large $idchar*+@qual = (@conid ".")* @varsym = $symbol $symchar* @consym = \: $symchar* @@ -69,118 +75,132 @@ haskell :- -<0> $white+ { c defaultStyle } -- whitespace+<0> $white+ ; <nestcomm> {- "{-" { m Comment commentStyle }- "-}" { m unComment commentStyle }- $white+ { c defaultStyle } -- whitespace- . { c commentStyle }+ "{-" { m CommentBlock (Comment Open) }+ "-}" { m unComment (Comment Close) }+ $white+ ; -- whitespace+ [^\-\{]+ { c $ Comment Text } -- rule to generate comments larger than 1 char+ . { c $ Comment Text } } <0> {- ^ "\begin{code}" { m (const CodeBlock) keywordStyle }- ^ ">" { m (const CodeLine) operatorStyle }- $white+ { c defaultStyle } -- whitespace- . { c latexStyle }+ ^ "\begin{code}" { m (const CodeBlock) $ Reserved Other }+ ^ ">" { m (const CodeLine) Operator }+ $white+ ; -- whitespace+ . { c $ Comment Text {-LaTeX-} } } <codeBlock> {- "\end{code}" { m (const LaTeX) keywordStyle }+ "\end{code}" { m (const LaTeXBlock) $ Reserved Other } - $white+ { c defaultStyle } -- whitespace+ $white+ ; -- whitespace -- The first rule matches operators that begin with --, eg --++-- is a valid--- operator and *not* a comment. +-- operator and *not* a comment. -- Note that we have to dissallow '-' as a symbol char for the first one--- of these because we may have -------- which would stilljust be the +-- of these because we may have -------- which would stilljust be the -- start of a comment.- "--"\-* [$symbol # \-] $symchar* { c defaultStyle }+ "--"\-* [$symbol # \-] $symchar* { c Operator } -- The next rule allows for the start of a comment basically -- it is -- followed by anything which isn't a symbol character -- (OR more '-'s). So for example "-----:" is still the start of a comment.- "--"~[$symbol # \-][^$nl]* { c commentStyle }--- Finally because the above rule had to add in a non symbol character + "--"~[$symbol # \-][^$nl]* { c $ Comment Line }+-- Finally because the above rule had to add in a non symbol character -- it's also possible that we have just finishing a line, -- people sometimes do this for example when breaking up paragraphs -- in a long comment.- "--"$nl { c commentStyle }-- "{-" { m Comment blockCommentStyle }+ "--"$nl { c $ Comment Line } - $special { c defaultStyle }+ "{-" { m CommentBlock $ Comment Open } - @reservedid { c keywordStyle }- @varid { c defaultStyle }- @conid { c typeStyle }+ ^"#".* { c $ CppDirective }+ $special { cs $ \(c:_) -> Special c }+ "deriving" { c (Reserved Deriving) }+ @reservedid { c (Reserved Other) }+ "module" { c (Reserved Module) }+ "where" { c (Reserved Where) }+ @layoutReservedId { c (Reserved OtherLayout) }+ `@qual @varid` { c Operator }+ `@qual @conid` { c ConsOperator }+ @qual @varid { c VarIdent }+ @qual @conid { c ConsIdent } - @reservedop { c operatorStyle }- @varsym { c operatorStyle }- @consym { c typeStyle }+ "|" { c (ReservedOp Pipe) }+ "=" { c (ReservedOp Equal) }+ @reservedop { c (ReservedOp OtherOp) }+ @qual @varsym { c Operator }+ @qual @consym { c ConsOperator } @decimal- | 0[oO] @octal- | 0[xX] @hexadecimal { c defaultStyle }+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c Number } @decimal \. @decimal @exponent?- | @decimal @exponent { c defaultStyle }+ | @decimal @exponent { c Number } - \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }- \" @string* \" { c stringStyle }- . { c operatorStyle }+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }+ \" @string* \" { c StringTok }+ . { c Unrecognized } } <codeLine> {- [\t\n\r\f\v]+ { m (const LaTeX) keywordStyle }+ [\t\n\r\f\v]+ { m (const LaTeXBlock) $ Reserved Other } - [\ \t]+ { c defaultStyle } -- whitespace+ [\ \t]+ ; -- whitespace -- Same three rules for line comments as above (see above for explanation).- "--"\-* [$symbol # \-] $symchar* { c defaultStyle }- "--"~[$symbol # \-][^$nl]* { c commentStyle }- "--"$nl { c commentStyle }-- "{-" { m Comment blockCommentStyle }+ "--"\-* [$symbol # \-] $symchar* { c Operator }+ "--"~[$symbol # \-][^$nl]* { c $ Comment Line }+ "--"$nl { c $ Comment Line } - $special { c defaultStyle }+ "{-" { m CommentBlock $ Comment Open } - @reservedid { c keywordStyle }- @varid { c defaultStyle }- @conid { c typeStyle }+ ^"#".* { c $ CppDirective }+ $special { cs $ \(c:_) -> Special c }+ "deriving" { c (Reserved Deriving) }+ @reservedid { c (Reserved Other) }+ "module" { c (Reserved Module) }+ "where" { c (Reserved Where) }+ @layoutReservedId { c (Reserved OtherLayout) }+ `@qual @varid` { c Operator }+ `@qual @conid` { c ConsOperator }+ @qual @varid { c VarIdent }+ @qual @conid { c ConsIdent } - @reservedop { c operatorStyle }- @varsym { c operatorStyle }- @consym { c typeStyle }+ "|" { c (ReservedOp Pipe) }+ "=" { c (ReservedOp Equal) }+ @reservedop { c (ReservedOp OtherOp) }+ @qual @varsym { c Operator }+ @qual @consym { c ConsOperator } @decimal- | 0[oO] @octal- | 0[xX] @hexadecimal { c defaultStyle }+ | 0[oO] @octal+ | 0[xX] @hexadecimal { c Number } @decimal \. @decimal @exponent?- | @decimal @exponent { c defaultStyle }+ | @decimal @exponent { c Number } - \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }- \" @string* \" { c stringStyle }- . { c operatorStyle }+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }+ \" @string* \" { c StringTok }+ . { c Unrecognized } } {-type Token = StyleName+ data HlState = CodeBlock | CodeLine- | Comment { unComment :: HlState }- | LaTeX+ | CommentBlock { unComment :: HlState }+ | LaTeXBlock deriving (Eq) -stateToInit (Comment _) = nestcomm-stateToInit CodeBlock = codeBlock-stateToInit CodeLine = codeLine-stateToInit LaTeX = 0--initState = LaTeX+stateToInit (CommentBlock _) = nestcomm+stateToInit CodeBlock = codeBlock+stateToInit CodeLine = codeLine+stateToInit LaTeXBlock = 0 -latexStyle = commentStyle+initState = LaTeXBlock #include "alex.hsinc"- }
+ Yi/Lexer/Ott.x view
@@ -0,0 +1,112 @@+-- -*- haskell -*-++{+{- The Ott website: http://www.cl.cam.ac.uk/~pes20/ott -}++{-# OPTIONS -w #-}+module Yi.Lexer.Ott+ ( initState, alexScanToken )+where+import Yi.Lexer.Alex+import Yi.Style+ ( Style ( .. )+ , StyleName+ )+import Yi.Style+}++@reservedid = metavar+ | indexvar+ | grammar+ | embed+ | subrules+ | contextrules+ | substitutions+ | single+ | multiple+ | freevars+ | defns+ | defn+ | by+ | homs+ | funs+ | fun++@reservedop = "::"+ | "::="+ | "_::"+ | "<::"+ | "/>"+ | "//"+ | "</"+ | IN+ | ".."+ | "..."+ | "...."+ | "----" "-"*++@homid = tex | com | coq | hol | isa | ocaml | icho | ich | "coq-equality"+ | isasyn | isaprec | lex | texvar | isavar | holvar | ocamlvar++main :-++<0> $white+ ;++<0>+{+ $white+ ; -- whitespace+ "%"[^\n]* { c commentStyle }+ ">>" { m (subtract 1) commentStyle }+ @reservedid { c keywordStyle }+ @reservedop { c operatorStyle }+ "|" $white+ { c operatorStyle }+ "(+" { m (const bindspec) numberStyle }+ "{{" { m (const beginHom) stringStyle }+ . { c defaultStyle }+}++<nestcomm> { + ">>" { m (subtract 1) commentStyle }+ "<<" { m (+1) commentStyle }+ $white+ ; -- whitespace+ . { c commentStyle }+}++<bindspec> {+ "bind" | "in" | "union" | "{" | "}" { c numberStyle }+ $white+ ; -- whitespace+ "+)" { m (const 0) numberStyle }+ . { c defaultStyle }+}++<beginHom> {+ $white* @homid { m (const hom) typeStyle }+ "" { m (const hom) defaultStyle }+}++<hom> {+ "[[" { m (const splice) stringStyle }+ $white+ ; -- whitespace+ "}}" { m (const 0) stringStyle }+ . { c defaultStyle }+}++<splice> {+ "]]" { m (const hom) stringStyle }+ $white+ ; -- whitespace+ . { c defaultStyle }+}++{+type HlState = Int++stateToInit x | x < 0 = nestcomm+ | otherwise = x++initState :: HlState+initState = 0++type Token = StyleName+#include "alex.hsinc"+}+
Yi/Lexer/Python.x view
@@ -116,10 +116,10 @@ @escape = \\ ($charesc | @ascii | @number) @gap = \\ $whitechar+ \\ -@shortstring = $graphic # [\"\\] | " " | @escape | @gap+@shortstring = $graphic # [\"\'\\] | " " | @escape | @gap @longstring = @shortstring | $nl -haskell :-+main :- <0> { $white+ { c defaultStyle }
Yi/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- Copyright (c) Tuomo Valkonen 2004. -- Copyright (c) Don Stewart 2004-5. -- Copyright (c) Jean-Philippe Bernardy 2006,2007.@@ -5,7 +6,7 @@ -- | This is the main module of Yi, called with configuration from the user. -- Here we mainly process command line arguments. -module Yi.Main (main, defaultConfig, projectName) where+module Yi.Main (main, defaultConfig, availableFrontends, projectName) where import Prelude () import qualified Yi.Keymap.Emacs as Emacs@@ -13,6 +14,9 @@ import qualified Yi.Keymap.Cua as Cua import Yi.Modes import qualified Yi.Mode.Haskell as Haskell+import Yi.Mode.IReader (ireaderMode, ireadMode)+import Yi.IReader (nextArticle, saveAsNewArticle)+import qualified Yi.Mode.Latex as Latex import {-# source #-} Yi.Boot import Yi.Config import Yi.Core hiding (file)@@ -56,8 +60,8 @@ #include "ghcconfig.h" -frontends :: [(String,UIBoot)]-frontends =+availableFrontends :: [(String,UIBoot)]+availableFrontends = #ifdef FRONTEND_COCOA ("cocoa", Yi.UI.Cocoa.start) : #endif@@ -73,7 +77,7 @@ [] frontendNames :: [String]-frontendNames = fmap fst' frontends+frontendNames = fmap fst' availableFrontends where fst' :: (a,UIBoot) -> a fst' (x,_) = x @@ -162,7 +166,7 @@ defaultConfig :: Config defaultConfig = - Config { startFrontEnd = snd (head frontends)+ Config { startFrontEnd = snd (head availableFrontends) , configUI = UIConfig { configFontSize = Nothing , configFontName = Nothing@@ -176,14 +180,18 @@ , startActions = [makeAction openScratchBuffer] -- emacs-style behaviour , publishedActions = defaultPublishedActions , modeTable = [AnyMode Haskell.cleverMode,- AnyMode latexMode2,+ AnyMode Latex.latexMode2,+ AnyMode Latex.latexMode, -- available but the other one is preferred AnyMode cppMode,- AnyMode literateHaskellMode,+ AnyMode Haskell.literateMode, AnyMode cabalMode,+ AnyMode gnuMakeMode, AnyMode srmcMode, AnyMode ocamlMode,+ AnyMode ottMode, AnyMode perlMode, AnyMode pythonMode,+ AnyMode ireaderMode, AnyMode fundamentalMode] , debugMode = False , configKillringAccumulate = False@@ -203,7 +211,7 @@ , ("Document" , box Document) , ("Forward" , box Forward) , ("Line" , box Line)- , ("Word" , box Word)+ , ("unitWord" , box unitWord) , ("Point" , box Point) , ("atBoundaryB" , box atBoundaryB) , ("cabalBuildE" , box cabalBuildE)@@ -214,7 +222,9 @@ , ("getSelectRegionB" , box getSelectRegionB) , ("grepFind" , box grepFind) , ("insertB" , box insertB)- , ("leftB" , box leftB) + , ("ireadMode" , box (withBuffer ireadMode >> nextArticle))+ , ("ireadSaveAsArticle" , box saveAsNewArticle)+ , ("leftB" , box leftB) , ("linePrefixSelectionB" , box linePrefixSelectionB) , ("mkRegion" , box mkRegion) , ("moveB" , box moveB)@@ -225,13 +235,16 @@ , ("regionOfPartNonEmptyB" , box regionOfPartNonEmptyB) , ("reloadEditor" , box reloadEditor) , ("reloadProjectE" , box reloadProjectE)+ , ("replaceString" , box replaceString) , ("revertE" , box revertE) , ("shell" , box shell) , ("setAnyMode" , box setAnyMode) , ("sortLines" , box sortLines) , ("unLineCommentSelectionB", box unLineCommentSelectionB) , ("unitParagraph" , box unitParagraph)+ , ("unitViWord" , box unitViWord) , ("writeB" , box writeB)+ , ("ghci" , box Haskell.ghciGet) ] where box x = [Data.Dynamic.toDyn x]@@ -256,7 +269,7 @@ getConfig :: Config -> Opts -> Either Err Config getConfig cfg opt = case opt of- Frontend f -> case lookup f frontends of+ Frontend f -> case lookup f availableFrontends of Just frontEnd -> return cfg { startFrontEnd = frontEnd } Nothing -> fail "Panic: frontend not found" Help -> throwError $ Err usage ExitSuccess
Yi/MiniBuffer.hs view
@@ -8,7 +8,7 @@ matchingBufferNames ) where -import Prelude (filter)+import Prelude (filter, length) import Data.List (isInfixOf) import Data.Maybe import Yi.Config@@ -87,10 +87,11 @@ oneOf [spec KDown, meta $ char 'n'] >>! down, oneOf [spec KTab, ctrl $ char 'i'] >>! completionFunction completer >>! showMatchings, ctrl (char 'g') ?>>! closeMinibuffer]- withEditor $ historyStartGen prompt msgEditor =<< getHint ""- b <- withEditor $ spawnMinibufferE (prompt ++ " ") (\bindings -> rebindings <|| (bindings >> write showMatchings))- withGivenBuffer b $ replaceBufferContent proposal+ withEditor $ do + historyStartGen prompt+ spawnMinibufferE (prompt ++ " ") (\bindings -> rebindings <|| (bindings >> write showMatchings))+ withBuffer0 $ replaceBufferContent proposal -- | Open a minibuffer, given a finite number of suggestions.@@ -142,6 +143,11 @@ instance Promptable String where getPromptedValue = return getPrompt _ = "String"++instance Promptable Char where+ getPromptedValue x = if length x == 0 then error "Please supply a character." + else return $ head x+ getPrompt _ = "Char" instance Promptable Int where getPromptedValue = return . read
Yi/Misc.hs view
@@ -68,10 +68,6 @@ ---------------------------- -- Cabal-related commands--setupScript :: String-setupScript = "Setup"- newtype CabalBuffer = CabalBuffer {cabalBuffer :: Maybe BufferRef} deriving (Initializable, Typeable, Binary) @@ -91,7 +87,7 @@ cabalRun :: String -> (Either Exception ExitCode -> YiM x) -> String -> YiM () cabalRun cmd onExit args = withOtherWindow $ do- b <- startSubprocess "runhaskell" (setupScript:cmd:words args) onExit+ b <- startSubprocess "cabal" (cmd:words args) onExit withEditor $ do maybeM deleteBuffer =<< cabalBuffer <$> getDynamic setDynamic $ CabalBuffer $ Just b
Yi/MkTemp.hs view
@@ -46,8 +46,8 @@ import System.IO.Error ( isAlreadyExistsError ) import GHC.IOBase ( IOException(IOError),- Exception(IOException), IOErrorType(AlreadyExists) )+import Control.Exception ( Exception(IOException) ) #ifndef __MINGW32__ import qualified System.Posix.Internals ( c_getpid )
Yi/Mode/Haskell.hs view
@@ -6,19 +6,16 @@ plainMode, cleverMode, preciseMode,+ literateMode,+ testMode, - -- * Buffer-level operations- haskellUnCommentSelectionB,- haskellCommentSelectionB,- haskellToggleCommentSelectionB,- -- * IO-level operations ghciGet, ghciLoadBuffer ) where import Data.Binary-import Data.List (isPrefixOf, dropWhile, takeWhile, filter, drop)+import Data.List (dropWhile, takeWhile, filter, drop) import Data.Maybe (maybe, listToMaybe, isJust) import Prelude (unwords) import Yi.Core@@ -32,17 +29,18 @@ import Yi.Syntax.Haskell as Hask import Yi.Syntax.Paren as Paren import Yi.Syntax.Tree+import Yi.Syntax.OnlineTree as OnlineTree import qualified Yi.IncrementalParse as IncrParser import qualified Yi.Lexer.Alex as Alex+import qualified Yi.Lexer.LiterateHaskell as LiterateHaskell import Yi.Lexer.Haskell as Haskell import qualified Yi.Syntax.Linear as Linear import qualified Yi.Mode.Interactive as Interactive import Yi.Modes (anyExtension) --- | Plain haskell mode, providing only list of stuff.-plainMode :: Mode (Linear.Result (Tok Token))-plainMode = emptyMode - {+haskellAbstract :: Mode syntax+haskellAbstract = emptyMode + { {- Some of these are a little questionably haskell related. For example ".x" is an alex lexer specification@@ -51,30 +49,58 @@ For now though this is probably okay given the users of 'yi' are mostly haskell hackers, as of yet. -} modeApplies = anyExtension ["hs", "x", "hsc", "hsinc"],+ modeName = "haskell",+ modeToggleCommentSelection = toggleCommentSelectionB "-- " "--"+ }++-- | Plain haskell mode, providing only list of keywords.+plainMode :: Mode (Linear.Result (Tok Token))+plainMode = haskellAbstract+ { modeName = "plain haskell", modeHL = ExtHL $ mkHighlighter (Linear.incrScanner . haskellLexer) (\begin end pos -> Linear.getStrokes begin end pos . fmap Paren.tokenToStroke) , modeIndent = \_ast -> autoIndentHaskellB } --- | "Clever" hasell mode, using the +-- | "Clever" haskell mode, using the paren-matching syntax. cleverMode :: Mode (Expr (Tok Haskell.Token))-cleverMode = emptyMode +cleverMode = haskellAbstract {- modeName = "haskell", modeApplies = modeApplies plainMode, modeIndent = cleverAutoIndentHaskellB, modeHL = ExtHL $- mkHighlighter (IncrParser.scanner Paren.parse . Paren.indentScanner . haskellLexer)+ mkHighlighter (skipScanner 50 . IncrParser.scanner Paren.parse . Paren.indentScanner . haskellLexer) (\point begin end t -> Paren.getStrokes point begin end t) , modeAdjustBlock = adjustBlock , modePrettify = cleverPrettify } --- | "Clever" hasell mode, using the +testMode :: Mode (OnlineTree.Tree TT)+testMode = haskellAbstract+ {+ modeApplies = modeApplies plainMode,+ modeHL = ExtHL $+ mkHighlighter (IncrParser.scanner OnlineTree.parse . haskellLexer)+ (\_point begin _end t -> fmap Hask.tokenToStroke $ dropToIndex begin t)++ }++literateMode :: Mode [Paren.Tree TT]+literateMode = haskellAbstract+ { modeName = "literate haskell"+ , modeApplies = anyExtension ["lhs"]+ , modeHL = ExtHL $+ mkHighlighter (IncrParser.scanner Paren.parse . Paren.indentScanner . literateHaskellLexer)+ (\point begin end t -> Paren.getStrokes point begin end t)+ , modeAdjustBlock = adjustBlock+ , modeIndent = cleverAutoIndentHaskellB+ , modePrettify = cleverPrettify }++-- | Experimental Haskell mode, using a rather precise parser for the syntax. preciseMode :: Mode (Hask.Tree TT)-preciseMode = emptyMode +preciseMode = haskellAbstract { modeName = "precise haskell", modeApplies = modeApplies plainMode,@@ -90,6 +116,8 @@ haskellLexer = Alex.lexScanner Haskell.alexScanToken Haskell.initState +literateHaskellLexer = Alex.lexScanner LiterateHaskell.alexScanToken LiterateHaskell.initState+ adjustBlock :: Expr (Tok Token) -> Int -> BufferM () adjustBlock e len = do p <- pointB@@ -233,24 +261,6 @@ , "--" ] ---- | Comments the region using haskell line comments-haskellCommentSelectionB :: BufferM ()-haskellCommentSelectionB = linePrefixSelectionB "-- "---- | uncomments a region of haskell line commented code-haskellUnCommentSelectionB :: BufferM ()-haskellUnCommentSelectionB = unLineCommentSelectionB "-- "--haskellToggleCommentSelectionB :: BufferM ()-haskellToggleCommentSelectionB = do- l <- readUnitB Yi.Core.Line- if ("--" `isPrefixOf` l)- then haskellUnCommentSelectionB- else haskellCommentSelectionB--- --------------------------- -- * Interaction with GHCi @@ -265,22 +275,25 @@ withEditor $ setDynamic $ GhciBuffer $ Just b return b --- | Return GHCi's buffer; create it if necessary+-- | Return GHCi's buffer; create it if necessary.+-- Show it in another window. ghciGet :: YiM BufferRef-ghciGet = do+ghciGet = withOtherWindow $ do GhciBuffer mb <- withEditor $ getDynamic case mb of Nothing -> ghci Just b -> do stillExists <- withEditor $ isJust <$> findBuffer b if stillExists - then return b+ then do withEditor $ switchToBufferE b+ return b else ghci -- | Send a command to GHCi ghciSend :: String -> YiM () ghciSend cmd = do b <- ghciGet+ withGivenBuffer b botB sendToProcess b (cmd ++ "\n") -- | Load current buffer in GHCi
+ Yi/Mode/IReader.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Rank2Types #-}+-- | A simple text mode; it does very little besides define a comment syntax.+-- We have it as a separate mode so users can bind the commands to this mode specifically.+module Yi.Mode.IReader where++import Yi.Buffer.Misc+import Yi.IReader+import Yi.Keymap.Keys+import Yi.Modes (anyExtension, fundamentalMode)+import Yi.Syntax (Stroke)+import qualified Yi.Syntax.Linear as Linear (Result)++abstract :: forall syntax. Mode syntax+abstract = fundamentalMode { modeApplies = anyExtension ["irtxt"],+ modeKeymap = ikeys }+ where -- Default bindings.+ -- ikeys :: (MonadInteract f Yi.Keymap.Action Event) => f () -> f ()+ ikeys = (choice [metaCh '1' ?>>! saveAndNextArticle,+ metaCh '2' ?>>! saveAsNewArticle,+ metaCh '3' ?>>! deleteAndNextArticle] <||)++ireaderMode :: Mode (Linear.Result Stroke)+ireaderMode = abstract { modeName = "interactive reading of text" }++ireadMode :: BufferM ()+ireadMode = setAnyMode (AnyMode ireaderMode)
Yi/Mode/Interactive.hs view
@@ -1,12 +1,13 @@ module Yi.Mode.Interactive where +import Data.List (elemIndex) import Prelude () import Yi.Core-import Yi.Region-import Yi.Lexer.Alex (Tok(..)) import Yi.History-import qualified Yi.Lexer.Compilation as Compilation-import qualified Yi.Mode.Compilation as Compilation+import Yi.Lexer.Alex (Tok(..))+import Yi.Region+import qualified Yi.Lexer.Compilation as Compilation+import qualified Yi.Mode.Compilation as Compilation import qualified Yi.Syntax.Linear as Linear atLastLine :: BufferM Bool@@ -16,21 +17,31 @@ mode :: Mode (Linear.Result (Tok Compilation.Token)) mode = Compilation.mode- { - modeApplies = const False,- modeName = "interactive",- modeKeymap = (<||) - (choice - [spec KEnter ?>>! do- eof <- withBuffer $ atLastLine- if eof- then feedCommand- else withSyntax modeFollow,- meta (char 'p') ?>>! interactHistoryMove 1,- meta (char 'n') ?>>! interactHistoryMove (-1) - ])- }+ { modeApplies = const False,+ modeName = "interactive",+ modeKeymap = (<||)+ (choice+ [spec KHome ?>>! ghciHome,+ spec KEnter ?>>! do+ eof <- withBuffer $ atLastLine+ if eof+ then feedCommand+ else withSyntax modeFollow,+ meta (char 'p') ?>>! interactHistoryMove 1,+ meta (char 'n') ?>>! interactHistoryMove (-1)+ ]) } +-- | The GHCi prompt always begins with ">"; this goes to just before it, or if one is already at the start+-- of the prompt, goes to the beginning of the line. (If at the beginning of the line, this pushes you forward to it.)+ghciHome :: BufferM ()+ghciHome = do l <- readLnB+ let epos = elemIndex '>' l+ case epos of+ Nothing -> moveToSol+ Just pos -> do (_,mypos) <- getLineAndCol+ if mypos == (pos+2) then moveToSol+ else moveToSol >> moveXorEol (pos+2)+ interactId :: String interactId = "Interact" @@ -44,11 +55,10 @@ interactHistoryStart = historyStartGen interactId getInputRegion :: BufferM Region-getInputRegion = do- mo <- getMarkB (Just "StdOUT")- p <- pointAt botB- q <- getMarkPointB mo- return $ mkRegion p q+getInputRegion = do mo <- getMarkB (Just "StdOUT")+ p <- pointAt botB+ q <- getMarkPointB mo+ return $ mkRegion p q getInput :: BufferM String getInput = readRegionB =<< getInputRegion@@ -68,14 +78,12 @@ setMode mode return b -- -- | Send the type command to the process feedCommand :: YiM () feedCommand = do b <- withEditor $ getBuffer withEditor interactHistoryFinish- cmd <- withBuffer $ do + cmd <- withBuffer $ do botB insertN "\n" me <- getMarkB (Just "StdERR")@@ -85,7 +93,6 @@ cmd <- readRegionB $ mkRegion p q setMarkPointB me p setMarkPointB mo p- return $ cmd + return $ cmd withEditor interactHistoryStart sendToProcess b cmd-
+ Yi/Mode/Latex.hs view
@@ -0,0 +1,41 @@+module Yi.Mode.Latex (latexMode, latexMode2) where++import Prelude ()+import Yi.Buffer+import Yi.Prelude+import Yi.Syntax+import qualified Yi.IncrementalParse as IncrParser+import qualified Yi.Lexer.Alex as Alex+import qualified Yi.Syntax.Linear as Linear+import qualified Yi.Syntax.Latex as Latex+import qualified Yi.Lexer.Latex as Latex+import Yi.Modes (anyExtension, mkHighlighter', fundamentalMode)+++abstract :: forall syntax. Mode syntax+abstract = fundamentalMode+ {+ modeApplies = anyExtension ["tex", "sty", "ltx"],+ modeToggleCommentSelection = toggleCommentSelectionB "% " "%"+ }++-- | token-based latex mode +latexMode :: Mode (Linear.Result Stroke)+latexMode = abstract+ {+ modeName = "plain latex",+ modeHL = ExtHL $ mkHighlighter' Latex.initState Latex.alexScanToken (Latex.tokenToStyle) + }++-- | syntax-based latex mode+latexMode2 :: Mode [Latex.Tree Latex.TT]+latexMode2 = abstract+ {+ modeApplies = modeApplies latexMode,+ modeName = "latex",+ modeHL = ExtHL $ + mkHighlighter (IncrParser.scanner Latex.parse . latexLexer)+ (\point begin end t -> Latex.getStrokes point begin end t)+ }+ where latexLexer = Alex.lexScanner Latex.alexScanToken Latex.initState+
Yi/Modes.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE Rank2Types #-} module Yi.Modes (fundamentalMode,- latexMode, cppMode, literateHaskellMode, cabalMode, srmcMode, ocamlMode,- perlMode, pythonMode, latexMode2,- anyExtension+ cppMode, cabalMode, srmcMode, ocamlMode,+ ottMode, gnuMakeMode,+ perlMode, pythonMode, + anyExtension, mkHighlighter' ) where import Control.Arrow (first)@@ -12,22 +14,19 @@ import Yi.Prelude import Yi.Style import Yi.Syntax-import qualified Yi.IncrementalParse as IncrParser import qualified Yi.Lexer.Alex as Alex import qualified Yi.Lexer.Cabal as Cabal import qualified Yi.Lexer.Cplusplus as Cplusplus-import qualified Yi.Lexer.Latex as Latex-import qualified Yi.Lexer.LiterateHaskell as LiterateHaskell+import qualified Yi.Lexer.GNUMake as GNUMake import qualified Yi.Lexer.OCaml as OCaml+import qualified Yi.Lexer.Ott as Ott import qualified Yi.Lexer.Perl as Perl import qualified Yi.Lexer.Python as Python import qualified Yi.Lexer.Srmc as Srmc import qualified Yi.Syntax.Linear as Linear-import qualified Yi.Syntax.Latex as Latex - fundamentalMode :: Mode syntax-latexMode, cppMode, literateHaskellMode, cabalMode, srmcMode, ocamlMode, perlMode, pythonMode :: Mode (Linear.Result Stroke)+cppMode, cabalMode, srmcMode, ocamlMode, ottMode, gnuMakeMode, perlMode, pythonMode :: Mode (Linear.Result Stroke) fundamentalMode = emptyMode { @@ -59,13 +58,6 @@ modeHL = ExtHL $ mkHighlighter' Cplusplus.initState Cplusplus.alexScanToken id } -literateHaskellMode = fundamentalMode- {- modeName = "literate haskell",- modeApplies = anyExtension ["lhs"],- modeHL = ExtHL $ mkHighlighter' LiterateHaskell.initState LiterateHaskell.alexScanToken id- }- cabalMode = fundamentalMode { modeName = "cabal",@@ -73,25 +65,7 @@ modeHL = ExtHL $ mkHighlighter' Cabal.initState Cabal.alexScanToken id } -latexLexer = Alex.lexScanner Latex.alexScanToken Latex.initState -latexMode = fundamentalMode- {- modeName = "plain latex",- modeApplies = anyExtension ["tex", "sty", "ltx"],- modeHL = ExtHL $ mkHighlighter' Latex.initState Latex.alexScanToken (Latex.tokenToStyle)- }--latexMode2 :: Mode [Latex.Tree Latex.TT]-latexMode2 = fundamentalMode- {- modeApplies = modeApplies latexMode,- modeName = "latex",- modeHL = ExtHL $ - mkHighlighter (IncrParser.scanner Latex.parse . latexLexer)- (\point begin end t -> Latex.getStrokes point begin end t)- }- srmcMode = fundamentalMode { modeName = "srmc",@@ -121,5 +95,33 @@ modeHL = ExtHL $ mkHighlighter' Python.initState Python.alexScanToken id } +isMakefile :: String -> Bool+isMakefile = matches . takeBaseName+ where matches "Makefile" = True+ matches "makefile" = True+ matches "GNUmakefile" = True+ matches filename = anyExtension ["mk"] filename+ -- TODO: .mk is fairly standard but are there others?++gnuMakeMode = fundamentalMode+ {+ modeName = "Makefile",+ modeApplies = isMakefile,+ modeHL = ExtHL $ mkHighlighter' GNUMake.initState GNUMake.alexScanToken id,+ modeIndentSettings = (modeIndentSettings fundamentalMode)+ {+ expandTabs = False,+ shiftWidth = 8+ }+ }++ottMode = fundamentalMode+ {+ modeName = "ott",+ modeApplies = anyExtension ["ott"],+ modeHL = ExtHL $ mkHighlighter' Ott.initState Ott.alexScanToken id+ }+ anyExtension :: [String] -> FilePath -> Bool anyExtension list fileName = or [takeExtension fileName == ('.' : ext) | ext <- list] +
Yi/Rectangle.hs view
@@ -1,4 +1,5 @@ -- Copyright (C) 2008 JP Bernardy+-- | emacs-style rectangle manipulation functions. module Yi.Rectangle where import Yi.Prelude@@ -21,6 +22,7 @@ [lowCol,highCol] <- sort <$> mapM colOf [regionStart r, regionEnd r] return (extR, lowCol, highCol) +-- | Split a list at the boundaries given multiSplit :: [Int] -> [a] -> [[a]] multiSplit [] l = [l] multiSplit (x:xs) l = left : multiSplit (fmap (subtract x) xs) right
Yi/Regex.hs view
@@ -10,7 +10,12 @@ where import Text.Regex.TDFA+import Text.Regex.TDFA.Pattern+import Text.Regex.TDFA.Common import Control.Monad+import Control.Applicative+import Text.Regex.TDFA.ReadRegex(parseRegex)+import Text.Regex.TDFA.TDFA(patternToDFA) type SearchExp = (String, Regex) @@ -29,19 +34,44 @@ data SearchF = IgnoreCase -- ^ Compile for matching that ignores char case | NoNewLine -- ^ Compile for newline-insensitive matching+ | QuoteRegex -- ^ Treat the input not as a regex but as a literal string to search for. deriving Eq searchOpt :: SearchF -> CompOption -> CompOption searchOpt IgnoreCase = \o->o{caseSensitive = False} searchOpt NoNewLine = \o->o{multiline = False}+searchOpt QuoteRegex = id +makeSearchOptsM' :: (Functor m, Monad m, RegexMaker Regex CompOption ExecOption source) => [SearchF] -> source -> m (source, Regex)+makeSearchOptsM' opts re = (\r->(re,r)) <$> makeRegexOptsM (searchOpts opts defaultCompOpt) defaultExecOpt re+ where searchOpts = foldr (.) id . map searchOpt -makeSearchOptsM :: (Monad m, RegexMaker Regex CompOption ExecOption source) => [SearchF] -> source -> m (source, Regex)-makeSearchOptsM opts re = liftM (\r->(re,r)) $ makeRegexOptsM (searchOpts opts defaultCompOpt) defaultExecOpt re- where searchOpts = foldr (.) id . map searchOpt+makeSearchOptsM :: [SearchF] -> String -> Either String (String, Regex)+makeSearchOptsM opts re = (\r->(re,r)) <$> compilePattern (searchOpts opts defaultCompOpt) defaultExecOpt <$> pattern+ where searchOpts = foldr (.) id . map searchOpt+ pattern = if QuoteRegex `elem` opts + then Right (literalPattern re) + else mapLeft show (parseRegex re) ++mapLeft f (Right a) = Right a+mapLeft f (Left a) = Left (f a)++-- | Return a pattern that matches its argument.+literalPattern source = (PConcat $ map (PChar (DoPa 0)) $ source, (0,DoPa 0))++compilePattern :: CompOption -- ^ Flags (summed together)+ -> ExecOption -- ^ Flags (summed together)+ -> (Pattern, (GroupIndex, DoPa)) -- ^ The pattern to compile+ -> Regex -- ^ Returns: the compiled regular expression+compilePattern compOpt execOpt source =+ let (dfa,i,tags,groups) = patternToDFA compOpt source+ in Regex dfa i tags groups compOpt execOpt++ emptySearch :: SearchExp emptySearch = ("", emptyRegex)+ -- | The regular expression that matches nothing. emptyRegex :: Regex
Yi/Region.hs view
@@ -17,6 +17,7 @@ , fmapRegion , intersectRegion , unionRegion+ , regionFirst, regionLast ) where import Yi.Buffer.Basic@@ -38,6 +39,15 @@ Backward -> " <- " ) ++ show (regionEnd r)++regionFirst :: Region -> Point+regionFirst (Region Forward p _) = p+regionFirst (Region Backward _ p) = p++regionLast :: Region -> Point+regionLast (Region Forward _ p) = p+regionLast (Region Backward p _) = p+ fmapRegion :: (Point -> Point) -> Region -> Region fmapRegion f (Region d x y) = Region d (f x) (f y)
Yi/Search.hs view
@@ -12,7 +12,7 @@ SearchMatch, SearchResult(..), SearchF(..),- searchAndRepRegion, -- :: String -> String -> Bool -> Region -> EditorM Bool+ searchAndRepRegion, searchAndRepUnit, -- :: String -> String -> Bool -> TextUnit -> EditorM Bool doSearch, -- :: (Maybe String) -> [SearchF] -- -> Direction -> YiM ()@@ -48,7 +48,7 @@ import Data.Char import Data.Maybe import Data.Either-import Data.List (span, takeWhile, take, filter)+import Data.List (span, takeWhile, take, filter, length) import Yi.Core import Yi.Core as Editor@@ -103,7 +103,7 @@ -- | Set up a search. searchInit :: String -> Direction -> [SearchF] -> EditorM (SearchExp, Direction) searchInit re d fs = do- let Just c_re = makeSearchOptsM fs re+ let Right c_re = makeSearchOptsM fs re setRegexE c_re setA searchDirectionA d return (c_re,d)@@ -133,25 +133,28 @@ ------------------------------------------------------------------------ -- | Search and replace in the given region.--- If the input boolean is True, then the replace is done globally.+-- If the input boolean is True, then the replace is done globally, otherwise only the first match is replaced -- Returns Bool indicating success or failure.-searchAndRepRegion :: String -> String -> Bool -> Region -> EditorM Bool-searchAndRepRegion [] _ _ _ = return False -- hmm...-searchAndRepRegion re str globally region = do- let Just c_re = makeSearchOptsM [] re- setRegexE c_re -- store away for later use- setA searchDirectionA Forward- mp <- withBuffer0 $- (if globally then id else take 1) <$>+searchAndRepRegion0 :: SearchExp -> String -> Bool -> Region -> BufferM Bool+searchAndRepRegion0 c_re str globally region = do+ mp <- (if globally then id else take 1) <$> filter (`includedRegion` region) <$> regexRegionB c_re region -- find the regex -- mp' is a maybe not reversed version of mp, the goal -- is to avoid replaceRegionB to mess up the next regions. -- So we start from the end. let mp' = mayReverse (reverseDir $ regionDirection region) mp- withBuffer0 $ mapM_ (`replaceRegionB` str) mp'+ mapM_ (`replaceRegionB` str) mp' return (not $ null mp) +searchAndRepRegion :: String -> String -> Bool -> Region -> EditorM Bool+searchAndRepRegion [] _ _ _ = return False -- hmm...+searchAndRepRegion s str globally region = do+ let c_re = makeSimpleSearch s+ setRegexE c_re -- store away for later use+ setA searchDirectionA Forward+ withBuffer0 $ searchAndRepRegion0 c_re str globally region+ ------------------------------------------------------------------------ -- | Search and replace in the region defined by the given unit. -- The rest is as in 'searchAndRepRegion'.@@ -188,24 +191,30 @@ isearchAddE :: String -> EditorM () isearchAddE increment = isearchFunE (++ increment) -makeISearch :: String -> (String, Regex)+makeSimpleSearch :: String -> SearchExp+makeSimpleSearch s = se+ where Right se = makeSearchOptsM [QuoteRegex] s++makeISearch :: String -> SearchExp makeISearch s = case makeSearchOptsM opts s of- Nothing -> (s, emptyRegex)- Just search -> search- where opts = if any isUpper s then [] else [IgnoreCase]+ Left _ -> (s, emptyRegex)+ Right search -> search+ where opts = QuoteRegex : if any isUpper s then [] else [IgnoreCase] isearchFunE :: (String -> String) -> EditorM () isearchFunE fun = do Isearch s <- getDynamic let (previous,p0,direction) = head s- let current = fun previous+ current = fun previous+ srch = makeISearch current printMsg $ "I-search: " ++ current- prevPoint <- withBuffer0 pointB- withBuffer0 $ do- moveTo $ regionStart p0- let srch = makeISearch current setRegexE srch- mp <- withBuffer0 $ regexB direction srch+ prevPoint <- withBuffer0 pointB+ mp <- withBuffer0 $ do+ moveTo $ regionStart p0+ when (direction == Backward) $+ moveN $ length current+ regexB direction srch case mp of [] -> do withBuffer0 $ moveTo prevPoint -- go back to where we were setDynamic $ Isearch ((current,p0,direction):s)@@ -305,9 +314,8 @@ ----------------- -- Query-Replace -{-- Find the next match and highlight it.--}+-- | Find the next match and select it.+-- Point is end, mark is beginning. qrNext :: Window -> BufferRef -> SearchExp -> EditorM () qrNext win b what = do mp <- withGivenBufferAndWindow0 win b $ regexB Forward what@@ -324,24 +332,14 @@ length as the pattern being replaced. -} qrReplaceAll :: Window -> BufferRef -> SearchExp -> String -> EditorM ()-qrReplaceAll win b what replacement =- do -- We must first replace the current match- qrReplaceCurrent win b replacement- qrAllRemaining - where- qrAllRemaining =- do mp <- withGivenBufferAndWindow0 win b $ regexB Forward what- case mp of- [] -> do printMsg "Replaced all occurrences"- qrFinish- (r:_) -> do replaceAction r- qrAllRemaining- replaceAction r = withGivenBufferAndWindow0 win b $ - replaceRegionB r replacement+qrReplaceAll win b what replacement = do+ withGivenBufferAndWindow0 win b $ do + exchangePointAndMarkB -- so we replace the current occurence too+ searchAndRepRegion0 what replacement True =<< regionOfPartB Document Forward+ printMsg "Replaced all occurrences"+ qrFinish -{-- Exit from query/replace.--}+-- | Exit from query/replace. qrFinish :: EditorM () qrFinish = do setA regexA Nothing@@ -362,4 +360,6 @@ -} qrReplaceCurrent :: Window -> BufferRef -> String -> EditorM () qrReplaceCurrent win b replacement = - withGivenBufferAndWindow0 win b $ modifySelectionB (const replacement)+ withGivenBufferAndWindow0 win b $ do+ flip replaceRegionB replacement =<< getRawestSelectRegionB+
Yi/Style.hs view
@@ -13,8 +13,14 @@ data Attributes = Attributes { foreground :: !Color , background :: !Color+ , reverseAttr :: !Bool + -- ^ The text should be show as "active" or "selected".+ -- This can be implemented by reverse video on the terminal. } deriving (Eq, Ord, Show) +emptyAttributes :: Attributes+emptyAttributes = Attributes { foreground = Default, background = Default, reverseAttr = False }+ -- | The style is used to transform attributes by modifying -- one or more of the visual text attributes. type Style = Endo Attributes@@ -23,6 +29,10 @@ data UIStyle = UIStyle { modelineAttributes :: Attributes -- ^ ground attributes for the modeline , modelineFocusStyle :: Style -- ^ transformation of modeline in focus+ + , tabBarAttributes :: Attributes -- ^ ground attributes for the tabbar+ , tabInFocusStyle :: Style -- ^ a tab that currently holds the focus+ , tabNotFocusedStyle :: Style -- ^ a tab that does not have the current focus , baseAttributes :: Attributes -- ^ ground attributes for the main text views @@ -31,10 +41,10 @@ , eofStyle :: Style -- ^ empty file marker colours , errorStyle :: Style -- ^ indicates errors in text- , hintStyle :: Style -- ^ search matches- , strongHintStyle :: Style -- ^ TODO: what is this?+ , hintStyle :: Style -- ^ search matches/paren matches/other hints+ , strongHintStyle :: Style -- ^ current search match - -- Syntaxt highlighting styles+ -- Syntax highlighting styles , commentStyle :: Style -- ^ all comments , blockCommentStyle :: Style -- ^ additional only for block comments , keywordStyle :: Style -- ^ applied to language keywords@@ -45,8 +55,10 @@ , typeStyle :: Style -- ^ type name (such as class in an OO language) , variableStyle :: Style -- ^ any standard variable (identifier) , operatorStyle :: Style -- ^ infix operators++ , makeFileAction :: Style -- ^ stuff that's passed to the shell in a Makefile+ , makeFileRuleHead :: Style -- ^ makefile rule headers }--- deriving (Eq, Show) type StyleName = UIStyle -> Style @@ -62,14 +74,15 @@ data Color = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8- | Default- | Reverse+ | Default + -- ^ The system-default color of the engine used.+ -- e.g. in Gtk this should pick whatever the user has chosen as default color + -- (background or forground depending on usage) for the text. deriving (Eq,Ord,Show) -- | Convert a color to its text specification, as to be accepted by XParseColor colorToText :: Color -> String colorToText Default = "default"-colorToText Reverse = "reverse" colorToText (RGB r g b) = ('#':) . showsHex r . showsHex g . showsHex b $ [] where showsHex x s = showHex1 (x `div` 16) : showHex1 (x `mod` 16) : s showHex1 x | x < 10 = chr (ord '0' + fromIntegral x)@@ -98,4 +111,3 @@ cyan = RGB 0 255 255 white = RGB 165 165 165 brightwhite = RGB 255 255 255-
Yi/Style/Library.hs view
@@ -9,12 +9,16 @@ -- | Abstract theme that provides useful defaults. defaultTheme :: Theme defaultTheme = Proto $ const $ UIStyle- { modelineAttributes = error "modeline must be redefined!"+ { modelineAttributes = error "modeline attributes must be redefined!" , modelineFocusStyle = withFg brightwhite - , baseAttributes = error "window must be redefined!"+ , tabBarAttributes = error "tabbar attributes must be redefined!"+ , tabInFocusStyle = withFg grey `mappend` withBg white+ , tabNotFocusedStyle = withFg lightGrey `mappend` withBg white - , selectedStyle = withFg Reverse `mappend` withBg Reverse+ , baseAttributes = error "base attributes must be redefined!"++ , selectedStyle = Endo $ \a -> a {reverseAttr = True} , eofStyle = withFg blue , errorStyle = withBg red , hintStyle = withBg cyan@@ -30,23 +34,30 @@ , typeStyle = withFg darkgreen , variableStyle = mempty , operatorStyle = withFg brown+ , makeFileRuleHead = withFg blue+ , makeFileAction = withFg grey } -- | The default UIStyle defaultLightTheme :: Theme defaultLightTheme = defaultTheme `override` \super _ -> super- { modelineAttributes = Attributes { foreground = black, background = darkcyan }- , baseAttributes = Attributes { foreground = Default, background = Default }+ { modelineAttributes = emptyAttributes { foreground = black, background = darkcyan }+ , tabBarAttributes = emptyAttributes { foreground = white, background = black }+ , baseAttributes = emptyAttributes } -- | A UIStyle inspired by the darkblue colorscheme of Vim. darkBlueTheme :: Theme darkBlueTheme = defaultTheme `override` \super _ -> super- { modelineAttributes = Attributes { foreground = darkblue, background = white }+ { modelineAttributes = emptyAttributes { foreground = darkblue, background = white } , modelineFocusStyle = withBg brightwhite - , baseAttributes = Attributes { foreground = white, background = black }+ , tabBarAttributes = emptyAttributes { foreground = darkblue, background = brightwhite }+ , tabInFocusStyle = withFg grey `mappend` withBg white+ , tabNotFocusedStyle = withFg lightGrey `mappend` withBg white++ , baseAttributes = emptyAttributes { foreground = white, background = black } , selectedStyle = withFg white `mappend` withBg blue , eofStyle = withFg red
Yi/Syntax.hs view
@@ -11,7 +11,7 @@ , Cache , Scanner (..) , ExtHL ( .. )- , noHighlighter, mkHighlighter+ , noHighlighter, mkHighlighter, skipScanner , Point(..), Size(..), Length, Stroke ) where@@ -46,12 +46,22 @@ data ExtHL syntax = forall a. ExtHL (Highlighter a syntax) data Scanner st a = Scanner {--- scanStart :: st -> Int, scanInit :: st, -- ^ Initial state- scanLooked :: st -> Point,+ scanLooked :: st -> Point, + -- ^ How far did the scanner look to produce this intermediate state?+ -- The state can be reused as long as nothing changes before that point. scanEmpty :: a, -- hack :/- scanRun :: st -> [(st,a)] -- ^ Running function returns a list of returns and intermediate states.+ scanRun :: st -> [(st,a)] + -- ^ Running function returns a list of results and intermediate states.+ -- Note: the state is the state /before/ producing the result in the second component. }++skipScanner :: Int -> Scanner st a -> Scanner st a+skipScanner n (Scanner i l e r) = Scanner i l e (other 0 . r)+ where other _ [] = []+ other _ [x] = [x] -- we must return the final result (because if the list is empty mkHighlighter thinks it can reuse the previous result)+ other 0 (x:xs) = x : other n xs+ other m (_:xs) = other (m-1) xs instance Functor (Scanner st) where fmap f (Scanner i l e r) = Scanner i l (f e) (\st -> fmap (second f) (r st))
Yi/Syntax/Haskell.hs view
@@ -116,10 +116,11 @@ -- -- isBefore' l (Tok {tokPosn = Posn {posnLn = l'}}) = +isEmpty :: Tree t -> Bool isEmpty Empty = True isEmpty _ = False --- parse :: P TT [Tree TT0+parse :: P TT (Tree TT) parse = parse' tokT tokFromT parse' :: (TT -> Token) -> (Token -> TT) -> P TT (Tree TT)
Yi/Syntax/Latex.hs view
@@ -53,14 +53,17 @@ where -- | Create a special character symbol newT c = tokFromT (Special c)- errT = newT '!'-+ -- errT = (\next -> case next of + -- Nothing -> newT '!'+ -- Just (Tok {tokPosn = posn}) -> Tok { tokT = Special '!', tokPosn = posn-1, tokSize = 1 -- FIXME: size should be 1 char, not one byte!+ -- }) <$> lookNext + errT = pure (newT '!') -- | parse a special symbol sym' p = symbol (p . tokT) sym t = sym' (== t) - pleaseSym c = recoverWith (pure $ errT) <|> sym c- pleaseSym' c = recoverWith (pure $ errT) <|> sym' c+ pleaseSym c = recoverWith errT <|> sym c+ pleaseSym' c = recoverWith errT <|> sym' c -- pExpr :: P TT [Expr TT] pExpr = many . pTree@@ -68,7 +71,7 @@ parens = [(Special x, Special y) | (x,y) <- zip "({[" ")}]"] openParens = fmap fst parens - pBlock = Paren <$> sym' isBegin <*> pExpr True <*> pleaseSym' isEnd+ pBlock = sym' isBegin >>= \beg@Tok {tokT = Begin env} -> Paren <$> pure beg <*> pExpr True <*> pleaseSym (End env) pTree :: Bool -> P TT (Tree TT) pTree outsideMath = @@ -78,7 +81,6 @@ <|> (Atom <$> sym' isNoise) <|> (Error <$> recoverWith (sym' (not . ((||) <$> isNoise <*> (`elem` openParens))))) --- TODO: (optimization) make sure we take in account the begin, so we don't return useless strokes getStrokes :: Point -> Point -> Point -> [Tree TT] -> [Stroke] getStrokes point _begin _end t0 = result where getStrokes' (Atom t) = ts id t@@ -111,6 +113,7 @@ | otherwise = (f (tokenToStroke t) :) list = foldr (.) id result = getStrokesL t0 []+ modStroke :: StyleName -> Stroke -> Stroke modStroke f (l,s,r) = (l,f `mappend` s,r)
Yi/Syntax/Linear.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types #-} -- Copyright (C) 2008 JP Bernardy module Yi.Syntax.Linear
+ Yi/Syntax/OnlineTree.hs view
@@ -0,0 +1,70 @@+module Yi.Syntax.OnlineTree (Tree(..), parse, dropToIndex) where+import Prelude ()+import Yi.Prelude+import Yi.IncrementalParse+import Control.Applicative+import Data.Traversable+import Data.Foldable+import Yi.Lexer.Alex+import Yi.Buffer.Basic (Point)+++data Tree a = Node a (Tree a) (Tree a)+ | Leaf+ deriving Show++instance Traversable Tree where+ traverse f (Node x l r) = Node <$> f x <*> traverse f l <*> traverse f r+ traverse _ Leaf = pure Leaf++instance Foldable Tree where+ foldMap = foldMapDefault++instance Functor Tree where+ fmap = fmapDefault++case_ :: (Maybe s -> Bool) -> P s a -> P s a -> P s a+case_ f true false = (testNext f *> true) <|> (testNext (not . f) *> false)++symbolBefore :: Point -> Maybe (Tok t) -> Bool+symbolBefore _ Nothing = False+symbolBefore p (Just x) = tokBegin x <= p++factor :: Int+factor = 2 ++initialLeftSize :: Size+initialLeftSize = 2 ++parse = parse' initialLeftSize 0 maxBound++-- Invariant: all symbols are after the l+-- | Parse all the symbols starting in the interval [lb, rb[+parse' :: Size -> Point -> Point -> P (Tok t) (Tree (Tok t))+parse' leftSize lB rB+ | rB <= lB = pure Leaf+ | otherwise = case_ (symbolBefore rB)+ (Node <$> symbol (const True)+ <*> parse' initialLeftSize lB midB+ <*> parse' (leftSize * fromIntegral factor) midB rB)+ (pure Leaf) + where midB = min rB (lB +~ leftSize)+ -- NOTE: eof here is important for performance (otherwise the+ -- parser would have to keep this case until the very end of input+ -- is reached.++toEndo Leaf = id+toEndo (Node x l r) = (x :) . toEndo l . toEndo r++dropToIndex :: Point -> Tree t -> [t]+dropToIndex index t = dropHelp initialLeftSize t index []++dropHelp :: Size -> Tree a -> Point -> [a] -> [a]+dropHelp _leftsize Leaf _n = id+dropHelp leftsize (Node x l r) index+ | fromIntegral index < leftsize = (x :) . dropHelp initialLeftSize l index . toEndo r+ -- the head is speculatively put in the result; but it does not matter, since we+ -- add only O(log n) elements this way.+ | otherwise = (x :) . dropHelp (leftsize * fromIntegral factor) r (index -~ leftsize)++
Yi/Syntax/Paren.hs view
@@ -1,5 +1,5 @@ -- Copyright (c) JP Bernardy 2008-+-- | Parser for haskell that takes in account only parenthesis and layout module Yi.Syntax.Paren where import Yi.IncrementalParse
+ Yi/Tag.hs view
@@ -0,0 +1,76 @@++-- | A module for CTags integration++module Yi.Tag+ (+ lookupTag,+ importTagTable,+ hintTags,+ completeTag,+ Tag,+ TagTable(..)+ )+where++{- Standard Library Module Imports -}++import Data.Maybe (mapMaybe)+import Data.List (isPrefixOf)+import System.FilePath (takeFileName, takeDirectory, FilePath, (</>))+import System.FriendlyPath+import Data.Map (Map, fromList, lookup, keys)++import qualified Data.Trie as Trie+++type Tag = String++data TagTable = TagTable { tagFileName :: FilePath+ -- ^ local name of the tag file+ -- TODO: reload if this file is changed+ , tagBaseDir :: FilePath+ -- ^ path to the tag file directory+ -- tags are relative to this path+ , tagFileMap :: Map Tag (FilePath, Int)+ -- ^ map from tags to files+ , tagTrie :: Trie.Trie+ -- ^ trie to speed up tag hinting+ }++-- | Find the location of a tag using the tag table.+-- Returns a full path and line number+lookupTag :: Tag -> TagTable -> Maybe (FilePath, Int)+lookupTag tag tagTable = do+ (file, line) <- Data.Map.lookup tag $ tagFileMap tagTable+ return $ (tagBaseDir tagTable </> file, line)++-- | Super simple parsing CTag format 1 parsing algorithm+-- TODO: support search patterns in addition to lineno+readCTags :: String -> Map Tag (FilePath, Int)+readCTags =+ fromList . mapMaybe (parseTagLine . words) . lines+ where parseTagLine [tag, tagfile, lineno] =+ -- remove ctag control lines+ if "!_TAG_" `isPrefixOf` tag then Nothing+ else Just (tag, (tagfile, read lineno))+ parseTagLine _ = Nothing++-- | Read in a tag file from the system+importTagTable :: FilePath -> IO TagTable+importTagTable filename = do+ friendlyName <- expandTilda filename+ tagStr <- readFile friendlyName+ let ctags = readCTags tagStr+ return $ TagTable { tagFileName = takeFileName filename,+ tagBaseDir = takeDirectory filename,+ tagFileMap = ctags,+ tagTrie = Trie.fromList $ keys ctags+ }++-- | Gives all the possible expanded tags that could match a given @prefix@+hintTags :: TagTable -> String -> [String]+hintTags tags prefix = map (prefix ++) $ Trie.possibleSuffixes prefix $ tagTrie tags++-- | Extends the string to the longest certain length+completeTag :: TagTable -> String -> String+completeTag tags prefix = prefix ++ (Trie.certainSuffix prefix $ tagTrie tags)
Yi/TextCompletion.hs view
@@ -45,11 +45,11 @@ Completion list <- getDynamic case list of (x:xs) -> do -- more alternatives, use them.- withBuffer0 $ do reg <- regionOfPartB Word Backward + withBuffer0 $ do reg <- regionOfPartB unitWord Backward replaceRegionB reg x setDynamic (Completion xs) [] -> do -- no alternatives, build them.- w <- withBuffer0 $ do readRegionB =<< regionOfPartB Word Backward+ w <- withBuffer0 $ do readRegionB =<< regionOfPartB unitWord Backward ws <- wordsForCompletion setDynamic (Completion $ (nubSet $ filter (matches w) ws) ++ [w]) -- We put 'w' back at the end so we go back to it after seeing@@ -104,7 +104,7 @@ wordsAndCurrentWord :: BufferM (String, [String]) wordsAndCurrentWord = do curText <- readRegionB =<< regionOfB Document- curWord <- readRegionB =<< regionOfPartB Word Backward+ curWord <- readRegionB =<< regionOfPartB unitWord Backward return (curWord, words' curText) wordsForCompletionInBuffer :: BufferM [String]
Yi/UI/Cocoa.hs view
@@ -21,6 +21,8 @@ import Yi.Keymap import Yi.Monad import Yi.Config+import Yi.Rectangle+import Yi.String import qualified Yi.UI.Common as Common import qualified Yi.WindowSet as WS import qualified Yi.Style as Style@@ -34,11 +36,42 @@ import Data.Maybe import Data.Monoid import Data.Unique-import qualified Data.Map as M -import Foundation hiding (name, new, parent, error, self, null)+-- Specify Cocoa imports explicitly, to avoid name-clashes.+-- Since the number of functions recognized by HOC varies+-- between revisions, this seems like the safest choice.+import HOC+import Foundation (+ NSPoint(..),NSRect(..),NSRange(..),NSSize(..),nsHeight,nsWidth,+ _NSThread,detachNewThreadSelectorToTargetWithObject,alloc,init,+ NSObject,toNSString,respondsToSelector,_NSMutableArray,array,+ _NSValue,valueWithRange,addObject,NSMutableArray)+import AppKit (+ frame,bounds,setFrame,NSView,_NSView,NSTextField,_NSTextField,+ NSCell,_NSSplitView,_NSImage,NSApplication,sharedApplication,+ terminate_,run,setApplicationIconImage,NSWindow,_NSWindow,_NSMenu,+ activateIgnoringOtherApps,makeKeyAndOrderFront,setMainMenu,+ addSubview,removeFromSuperview,Has_setBackgroundColor,+ Has_setTextColor,NSSplitView,_NSFont,addSubviewPositionedRelativeTo,+ fontWithNameSize,setUserFixedPitchFont,userFixedPitchFontOfSize,+ adjustSubviews,cell,center,containerSize,nsWindowBelow,+ initWithContentRectStyleMaskBackingDefer,initWithContentsOfFile,+ initWithFrame,layoutManager,makeFirstResponder,+ nsBackingStoreBuffered,nsClosableWindowMask,nsLeftTextAlignment,+ nsLineBreakByTruncatingMiddle,nsMiniaturizableWindowMask,+ nsResizableWindowMask,nsTitledWindowMask,nsViewHeightSizable,+ nsViewMaxYMargin,nsViewNotSizable,nsViewWidthSizable,+ performMiniaturize,replaceTextStorage,scrollRangeToVisible,+ setAlignment,setAutodisplay,setAutohidesScrollers,+ setAutoresizingMask,setBackgroundColor,setBezeled,setBordered,+ setContainerSize,setDelegate,setDocumentView,setEditable,+ setFrameAutosaveName,setHasHorizontalScroller,setHasVerticalScroller,+ setHorizontallyResizable,setInsertionPointColor,setLineBreakMode,+ setRichText,setSelectable,setSelectedRanges,NSLayoutManager,+ setSelectedTextAttributes,setStringValue,setTextColor,setTitle,+ setVerticallyResizable,setWidthTracksTextView,setWindowsMenu,+ setWraps,sizeToFit,textColor,textContainer) -import AppKit hiding (windows, start, rect, width, content, prompt, dictionary, icon, concat, remove, insert, update, convertAttributes) import qualified AppKit.NSWindow import qualified AppKit.NSView @@ -49,23 +82,32 @@ foreign import ccall "Processes.h SetFrontProcess" setFrontProcess :: Ptr (CInt) -> IO (CInt) foreign import ccall "Processes.h GetCurrentProcess" getCurrentProcess :: Ptr (CInt) -> IO (CInt) +-- Don't import this, since it is only available in Leopard...+$(declareRenamedSelector "setAllowsNonContiguousLayout:" "setAllowsNonContiguousLayout" [t| Bool -> IO () |])+instance Has_setAllowsNonContiguousLayout (NSLayoutManager a)+_silenceWarning :: ImpType_setAllowsNonContiguousLayout a b+_silenceWarning = undefined+ ------------------------------------------------------------------------ data UI = UI {uiWindow :: NSWindow () ,uiBox :: NSSplitView () ,uiCmdLine :: NSTextField ()- ,uiBuffers :: IORef (M.Map BufferRef TextStorage) ,windowCache :: IORef [WinInfo] ,uiActionCh :: Action -> IO ()- ,uiConfig :: UIConfig+ ,uiFullConfig :: Config } +uiConfig :: UI -> UIConfig+uiConfig = configUI . uiFullConfig+ data WinInfo = WinInfo { wikey :: !Unique -- ^ Uniquely identify each window , window :: Window -- ^ The editor window that we reflect , textview :: YiTextView () , modeline :: NSTextField () , widget :: NSView () -- ^ Top-level widget for this window.+ , storage :: TextStorage } mkUI :: UI -> Common.UI@@ -76,8 +118,8 @@ , Common.refresh = refresh ui } -rect :: Float -> Float -> Float -> Float -> NSRect-rect x y w h = NSRect (NSPoint x y) (NSSize w h)+mkRect :: Float -> Float -> Float -> Float -> NSRect+mkRect x y w h = NSRect (NSPoint x y) (NSSize w h) allSizable, normalWindowMask :: CUInt allSizable = nsViewWidthSizable .|. nsViewHeightSizable@@ -111,8 +153,8 @@ cl # setLineBreakMode nsLineBreakByTruncatingMiddle return tl -addSubviewWithTextLine :: forall t1 t2. NSView t1 -> NSView t2 -> IO (NSTextField (), NSView ())-addSubviewWithTextLine view parent = do+addSubviewWithTextLine :: Maybe (NSView t0) -> NSView t1 -> NSView t2 -> IO (NSTextField (), NSView ())+addSubviewWithTextLine sibling view parent = do container <- new _NSView parent # bounds >>= flip setFrame container container # setAutoresizingMask allSizable@@ -121,12 +163,15 @@ text <- newTextLine container # addSubview text- parent # addSubview container+ case sibling of+ Nothing -> parent # addSubview container+ Just v -> parent # addSubviewPositionedRelativeTo container nsWindowBelow v+ -- Adjust frame sizes, as superb cocoa cannot do this itself... txtbox <- text # frame winbox <- container # bounds- view # setFrame (rect 0 (nsHeight txtbox) (nsWidth winbox) (nsHeight winbox - nsHeight txtbox))- text # setFrame (rect 0 0 (nsWidth winbox) (nsHeight txtbox))+ view # setFrame (mkRect 0 (nsHeight txtbox) (nsWidth winbox) (nsHeight winbox - nsHeight txtbox))+ text # setFrame (mkRect 0 0 (nsWidth winbox) (nsHeight txtbox)) return (text, container) @@ -148,6 +193,7 @@ app <- _YiApplication # sharedApplication >>= return . toYiApplication app # setIVar _eventChannel (Just ch)+ app # setIVar _runAction (Just $ outCh . singleton . makeAction) -- Multithreading in Cocoa is initialized by spawning a new thread -- This spawns a thread that immediately exits, but that's okay@@ -174,7 +220,7 @@ -- Create main cocoa window...- win <- _NSWindow # alloc >>= initWithContentRect (rect 0 0 480 340)+ win <- _NSWindow # alloc >>= initWithContentRect (mkRect 0 0 480 340) win # setTitle (toNSString "Yi") content <- win # AppKit.NSWindow.contentView >>= return . toNSView content # setAutoresizingMask allSizable@@ -186,7 +232,7 @@ -- Create yi window container winContainer <- new _NSSplitView- (cmd,_) <- content # addSubviewWithTextLine winContainer+ (cmd,_) <- content # addSubviewWithTextLine Nothing winContainer -- Activate application window win # center@@ -194,10 +240,9 @@ win # makeKeyAndOrderFront nil app # activateIgnoringOtherApps False - bufs <- newIORef M.empty wc <- newIORef [] - let ui = UI win winContainer cmd bufs wc (outCh . singleton) (configUI cfg)+ let ui = UI win winContainer cmd wc (outCh . singleton) cfg cmd # setColors (Style.baseAttributes $ configStyle $ uiConfig ui) @@ -214,19 +259,19 @@ syncWindows :: Editor -> UI -> [(Window, Bool)] -> [WinInfo] -> IO [WinInfo] syncWindows e ui = sync where - sync ws [] = mapM insert ws+ sync ws [] = mapM (insert Nothing) ws sync [] cs = mapM_ remove cs >> return [] sync (w:ws) (c:cs) | match w c = (:) <$> update w c <*> sync ws cs | L.any (match w) cs = remove c >> sync (w:ws) cs- | otherwise = (:) <$> insert w <*> sync ws (c:cs)+ | otherwise = (:) <$> insert (Just $ widget c) w <*> sync ws (c:cs) match w c = winkey (fst w) == winkey (window c) winbuf = flip findBufferWith e . bufkey remove = removeFromSuperview . widget- insert (w,f) = update (w,f) =<< newWindow ui w (winbuf w)+ insert before (w,f) = update (w,f) =<< newWindow before ui w (winbuf w) update (w, False) i = return (i{window = w}) update (w, True) i = do (textview i) # AppKit.NSView.window >>= makeFirstResponder (textview i)@@ -238,9 +283,9 @@ getColor False (Style.background s) >>= flip setBackgroundColor slf -- | Make A new window-newWindow :: UI -> Window -> FBuffer -> IO WinInfo-newWindow ui win b = do- v <- alloc _YiTextView >>= initWithFrame (rect 0 0 100 100)+newWindow :: Maybe (NSView t) -> UI -> Window -> FBuffer -> IO WinInfo+newWindow before ui win b = do+ v <- alloc _YiTextView >>= initWithFrame (mkRect 0 0 100 100) v # setRichText False v # setSelectable True v # setAlignment nsLeftTextAlignment@@ -266,15 +311,15 @@ prect <- prompt # frame vrect <- v # frame - hb <- _NSView # alloc >>= initWithFrame (rect 0 0 (nsWidth prect + nsWidth vrect) (nsHeight prect))- v # setFrame (rect (nsWidth prect) 0 (nsWidth vrect) (nsHeight prect))+ hb <- _NSView # alloc >>= initWithFrame (mkRect 0 0 (nsWidth prect + nsWidth vrect) (nsHeight prect))+ v # setFrame (mkRect (nsWidth prect) 0 (nsWidth vrect) (nsHeight prect)) v # setAutoresizingMask nsViewWidthSizable hb # addSubview prompt hb # addSubview v hb # setAutoresizingMask nsViewWidthSizable brect <- (uiBox ui) # bounds- hb # setFrame (rect 0 0 (nsWidth brect) (nsHeight prect))+ hb # setFrame (mkRect 0 0 (nsWidth brect) (nsHeight prect)) (uiBox ui) # addSubview hb dummy <- _NSTextField # alloc >>= init@@ -298,13 +343,16 @@ scroll # setHasHorizontalScroller False scroll # setAutohidesScrollers (configAutoHideScrollBar $ uiConfig ui) scroll # setIVar _leftScroller (configLeftSideScrollBar $ uiConfig ui)- addSubviewWithTextLine scroll (uiBox ui)+ addSubviewWithTextLine before scroll (uiBox ui) -- TODO: Support focused modeline... ml # setColors (Style.modelineAttributes sty)- storage <- getTextStorage ui b- layoutManager v >>= replaceTextStorage storage+ s <- newTextStorage (configStyle $ uiConfig ui) (snd $ runBuffer win b revertPendingUpdatesB) win+ layoutManager v >>= replaceTextStorage s + responds <- layoutManager v >>= respondsToSelector (getSelectorForName "setAllowsNonContiguousLayout:")+ when responds $ layoutManager v >>= setAllowsNonContiguousLayout True+ k <- newUnique flip (setIVar _runBuffer) v $ \act -> do wCache <- readIORef (windowCache ui)@@ -318,18 +366,35 @@ , textview = v , modeline = ml , widget = view+ , storage = s } +getSelectedRegions :: BufferM [Region]+getSelectedRegions = do+ rect <- getA rectangleSelectionA+ if (not rect)+ then singleton <$> (getSelectRegionB >>= charRegionB)+ else do+ (reg, x1, x2) <- getRectangle+ ls <- map (fromIntegral . L.length) <$> lines' <$> readRegionB reg+ mapM charRegionB $ catMaybes $ snd $ L.mapAccumL+ (lineRegions (fromIntegral x1) (fromIntegral x2)) (regionStart reg) ls+ where+ lineRegions :: Size -> Size -> Point -> Size -> (Point, Maybe Region)+ lineRegions x1 x2 p l + | l <= x1 = (p +~ succ l, Nothing)+ | l <= x2 = (p +~ succ l, Just $ mkRegion (p+~x1) (p +~ l))+ | otherwise = (p +~ succ l, Just $ mkRegion (p+~x1) (p +~ x2))++ refresh :: UI -> Editor -> IO ()-refresh ui e = logNSException "refresh" $ do+refresh ui e = withAutoreleasePool $ logNSException "refresh" $ do+ _YiApplication # sharedApplication >>=+ pushClipboard (snd $ runEditor (uiFullConfig ui) getRegE e) . toYiApplication+ (uiCmdLine ui) # setStringValue (toNSString $ statusLine e) cache <- readRef $ windowCache ui- forM_ (buffers e) $ \buf -> do- storage <- getTextStorage ui buf- storage # setMonospaceFont -- FIXME: Why is this needed for mini buffers?- storage # setTextStorageBuffer buf- (uiWindow ui) # setAutodisplay False -- avoid redrawing while window syncing cache' <- syncWindows e ui (toList $ WS.withFocus $ windows e) cache writeRef (windowCache ui) cache'@@ -338,20 +403,14 @@ forM_ cache' $ \w -> do let buf = findBufferWith (bufkey (window w)) e- let ((p0,p1,showSel,txt),_) = runBuffer (window w) buf $- (,,,) <$> pointB <*> getMarkPointB staticSelMark <*>- getA highlightSelectionA <*> getModeLine- let (p,l) = if showSel then (min p0 p1, abs $ p1~-p0) else (p0,0)- (textview w) # setSelectedRange (NSRange (fromIntegral p) (fromIntegral l))+ (storage w) # setMonospaceFont -- FIXME: Why is this needed for mini buffers?+ (storage w) # setTextStorageBuffer e buf++ let ((p0,txt,rs),_) = runBuffer (window w) buf $+ (,,) <$> (pointB >>= charIndexB) <*> getModeLine <*> getSelectedRegions+ a <- castObject <$> _NSMutableArray # array :: IO (NSMutableArray ())+ mapM_ ((flip addObject a =<<) . flip valueWithRange _NSValue . mkRegionRange) rs+ (textview w) # setSelectedRanges (castObject a) (textview w) # scrollRangeToVisible (NSRange (fromIntegral p0) 0) (modeline w) # setStringValue (toNSString txt)--getTextStorage :: UI -> FBuffer -> IO TextStorage-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 (configStyle $ uiConfig ui) b- modifyRef bufsRef (M.insert (bkey b) storage)- return storage+ (textview w) # visibleRange >>= flip visibleRangeChanged (storage w)
Yi/UI/Cocoa/Application.hs view
@@ -25,25 +25,42 @@ , _YiController , initializeClass_Application , _eventChannel+ , _runAction , setAppleMenu , ImpType_setAppleMenu+ , pushClipboard ) where +import Prelude ()+import Yi.Prelude+ import Control.Concurrent import Control.Monad import Data.Bits -import Yi.Debug+import Yi.Editor import Yi.Event import Yi.UI.Cocoa.Utils import Foreign.C -import HOC ()--import Foundation hiding (name, new, parent, error, self, null)-import AppKit hiding (windows, start, rect, width, content, prompt, dictionary, icon, concat)+-- Specify Cocoa imports explicitly, to avoid name-clashes.+-- Since the number of functions recognized by HOC varies+-- between revisions, this seems like the safest choice.+import HOC+import Foundation (+ NSObject,NSObjectClass,NSNotification,synchronize,_NSUserDefaults,+ standardUserDefaults,_NSArray,arrayWithObject,haskellString,+ _NSTimer,scheduledTimerWithTimeIntervalTargetSelectorUserInfoRepeats,+ toNSString)+import AppKit (+ NSEvent,NSMenu,NSApplication,NSApplicationClass,run,sendEvent,+ applicationShouldTerminateAfterLastWindowClosed,_NSPasteboard,+ applicationWillTerminate,generalPasteboard,availableTypeFromArray,+ charactersIgnoringModifiers,declareTypesOwner,modifierFlags,+ nsKeyDown,nsStringPboardType,setStringForType,changeCount,+ stringForType,nsFlagsChanged) foreign import ccall "RtsAPI.h shutdownHaskellAndExit" shutdownHaskellAndExit :: CInt -> IO () @@ -96,14 +113,45 @@ instance Has_setAppleMenu (NSApplication a) $(exportClass "YiApplication" "ya_" [ InstanceVariable "eventChannel" [t| Maybe (Yi.Event.Event -> IO ()) |] [| Nothing |]+ , InstanceVariable "runAction" [t| Maybe (EditorM () -> IO ()) |] [| Nothing |]+ , InstanceVariable "lastPaste" [t| String |] [| "" |]+ , InstanceVariable "lastChangeCount" [t| CInt |] [| 0 |] , InstanceMethod 'run -- ' , InstanceMethod 'doTick -- ' , InstanceMethod 'sendEvent -- ' ]) ya_doTick :: YiApplication () -> IO ()-ya_doTick _ = replicateM_ 4 yield+ya_doTick slf = do+ pb <- _NSPasteboard # generalPasteboard+ cc <- pb # changeCount+ oc <- slf #. _lastChangeCount+ when (cc /= oc) $ do+ slf # setIVar _lastChangeCount cc+ ar <- _NSArray # arrayWithObject nsStringPboardType+ ty <- pb # availableTypeFromArray (castObject ar)+ when (ty /= nil) $ do+ news <- pb # stringForType ty >>= haskellString+ olds <- slf #. _lastPaste+ when (news /= olds) $ do+ slf # setIVar _lastPaste news+ Just runAct <- slf #. _runAction+ runAct (setRegE news)+ + replicateM_ 4 yield +pushClipboard :: String -> YiApplication () -> IO ()+pushClipboard news slf = do+ olds <- slf #. _lastPaste+ when (news /= olds) $ do+ slf # setIVar _lastPaste news+ ar <- _NSArray # arrayWithObject nsStringPboardType+ pb <- _NSPasteboard # generalPasteboard+ cc <- pb # declareTypesOwner (castObject ar) nil+ pb # setStringForType (toNSString news) nsStringPboardType+ slf # setIVar _lastChangeCount cc+ return ()+ ya_run :: YiApplication () -> IO () ya_run self = do -- Schedule a timer that repeatedly invokes ya_doTick in order to have@@ -118,7 +166,10 @@ t <- event # (rawType :: ImpType_rawType (NSEvent t) inst) if t == fromCEnum nsKeyDown then self #. _eventChannel >>= handleKeyEvent event- else super self # sendEvent event+ else if t == fromCEnum nsFlagsChanged+ then do+ logPutStrLn $ "Flags changed"+ else super self # sendEvent event handleKeyEvent :: forall t. NSEvent t -> Maybe (Yi.Event.Event -> IO ()) -> IO () handleKeyEvent event mch = do@@ -134,6 +185,7 @@ "\63233" -> (Just KDown, True) "\63234" -> (Just KLeft, True) "\63235" -> (Just KRight, True)+ "\63272" -> (Just KDel, True) "\63273" -> (Just KHome, True) "\63275" -> (Just KEnd, True) "\63276" -> (Just KPageUp, True)@@ -145,7 +197,7 @@ _ -> return () modifierTable :: Bool -> [(CUInt, Modifier)]-modifierTable False = [(bit 18,MCtrl), (bit 19,MMeta)]+modifierTable False = [(bit 18,MCtrl), (bit 19,MMeta), (bit 20,MSuper)] modifierTable True = (bit 17,MShift) : modifierTable False modifiers :: Bool -> CUInt -> [Modifier]
Yi/UI/Cocoa/TextStorage.hs view
@@ -14,24 +14,42 @@ , visibleRangeChanged ) where -import Prelude (take, dropWhile)+import Prelude (takeWhile, take, dropWhile, drop, span, unzip)+import Yi.Editor (regex, emptyEditor, Editor) import Yi.Prelude import Yi.Buffer import Yi.Style import Yi.Syntax import Yi.UI.Cocoa.Utils import Yi.UI.Utils+import Yi.Window import Data.Maybe import qualified Data.Map as M+import qualified Data.List as L import Foreign hiding (new) import Foreign.C -import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.UTF8 as LB -import Foundation hiding (minimum, new, init, null, error)-import AppKit hiding (concat, dictionary, convertAttributes)+-- Specify Cocoa imports explicitly, to avoid name-clashes.+-- Since the number of functions recognized by HOC varies+-- between revisions, this seems like the safest choice.+import HOC+import Foundation (+ Unichar,NSString,NSStringClass,NSDictionary,NSRange(..),NSRangePointer,+ length,attributeAtIndexEffectiveRange,attributesAtIndexEffectiveRange,+ attributesAtIndexLongestEffectiveRangeInRange,nsMaxRange,+ beginEditing,endEditing,setAttributesRange,haskellString,+ substringWithRange,initWithStringAttributes,alloc,+ addAttributeValueRange,addAttributesRange)+import AppKit (+ NSTextStorage,NSTextStorageClass,string,fixesAttributesLazily,+ _NSCursor,_NSFont,replaceCharactersInRangeWithString,+ _NSParagraphStyle,defaultParagraphStyle,ibeamCursor,_NSTextStorage,+ editedRangeChangeInLength,nsTextStorageEditedAttributes,+ nsTextStorageEditedCharacters,userFixedPitchFontOfSize) -- Unfortunately, my version of hoc does not handle typedefs correctly, -- and thus misses every selector that uses the "unichar" type, even@@ -52,7 +70,7 @@ $(declareClass "YiLBString" "NSString") $(exportClass "YiLBString" "yls_" [- InstanceVariable "str" [t| LB.ByteString |] [| LB.empty |]+ InstanceVariable "str" [t| LB.ByteString |] [| LB.fromString "" |] , InstanceMethod 'length -- ' , InstanceMethod 'characterAtIndex -- ' , InstanceMethod 'getCharactersRange -- '@@ -63,24 +81,29 @@ -- logPutStrLn $ "Calling yls_length (gah...)" slf #. _str >>= return . fromIntegral . LB.length --- TODO: The result type should be UTF16... yls_characterAtIndex :: CUInt -> YiLBString () -> IO Unichar yls_characterAtIndex i slf = do -- logPutStrLn $ "Calling yls_characterAtIndex " ++ show i- slf #. _str >>= return . fromIntegral . flip LB.index (fromIntegral i)+ slf #. _str >>= return . last . encodeUTF16 . fromEnum . fst . fromJust . LB.decode . LB.drop (fromIntegral i) --- TODO: Should get an array of characters in UTF16... yls_getCharactersRange :: Ptr Unichar -> NSRange -> YiLBString () -> IO () yls_getCharactersRange p _r@(NSRange i l) slf = do -- logPutStrLn $ "Calling yls_getCharactersRange " ++ show r slf #. _str >>= pokeArray p .- take (fromIntegral l) . -- TODO: Is l given in bytes or characters?- fmap fromIntegral . -- TODO: UTF16 recode- LB.unpack .+ concatMap (encodeUTF16 . fromEnum) .+ LB.toString .+ LB.take (fromIntegral l) . -- TODO: Is l given in bytes or characters? LB.drop (fromIntegral i) +encodeUTF16 :: Int -> [Unichar]+encodeUTF16 c+ | c < 0x10000 = [fromIntegral c]+ | otherwise = let c' = c - 0x10000+ in [0xd800 .|. (fromIntegral $ c' `shiftR` 10),+ 0xdc00 .|. (fromIntegral $ c' .&. 0x3ff)] + -- An implementation of NSTextStorage that uses Yi's FBuffer as -- the backing store. An implementation must at least implement -- a O(1) string method and attributesAtIndexEffectiveRange.@@ -93,87 +116,163 @@ -- queried for the same location multiple times, and thus caching -- them as well also seems fruitful. --- Unfortunately HOC does not export Instance Variables, and thus--- we cannot provide a type signature for withCache--- withCache :: (InstanceVariables st iv) => st -> IVar iv (Maybe vt) -> (vt -> Bool) -> IO vt -> IO vt---- | Obtain the result of the action and cache that as the--- instance variable ivar in self. Use existing cache if--- a result is stored, and cond says it is still valid.-withCache slf ivar cond act = do- cache <- slf #. ivar- case cache of- Just val | cond val -> return val- _ -> do- val <- act- slf # setIVar ivar (Just val)- return val- -- | Use this as the base length of computed stroke ranges strokeRangeExtent :: Num t => t-strokeRangeExtent = 2000+strokeRangeExtent = 4000 -type Picture = [(Point, Attributes)]+type PicStroke = (Point, Attributes)+data Picture = Picture+ { picRegion :: Region+ , picStrokes :: [PicStroke]+ } +instance Show Picture where+ show (Picture r ss) = "{{"++show r ++": "++show (take 1 ss)++"@"++show (L.length ss)++"}}"++emptyPicture :: (Picture, NSRange)+emptyPicture = (Picture emptyRegion [], NSRange 0 0)++nullPicture :: Picture -> Bool+nullPicture = null . picStrokes -- Or empty region??++regionEnds :: Region -> (Point, Point)+regionEnds r = (regionStart r, regionEnd r)++dropStrokesWhile :: (PicStroke -> Bool) -> Picture -> Picture+dropStrokesWhile f pic = pic { picRegion = mkRegion nb pe, picStrokes = strokes }+ where + (pb, pe) = regionEnds $ picRegion pic+ (nb, strokes) = helper pb (picStrokes pic)+ helper :: Point -> [PicStroke] -> (Point, [PicStroke])+ helper p [] = (p,[])+ helper p ~(x:xs)+ | f x = helper (fst x) xs+ | otherwise = (p, x:xs)++-- | Extend the currently cached picture, so that it at least+-- covers the desired region. The resulting picture starts+-- at the location of the desired region, but might extend+-- further...+extendPicture :: Region -> (Region -> IO Picture) -> Picture -> IO Picture+extendPicture desired ext cache = do+ -- All possible overlappings of desired and cache regions:+ -- dd dd ddd ddd dddd dd dd ddd dd dd dd ddd dd <- desired+ -- cc cc ccc cc cc ccc cc cc cccc ccc cc ccc cc <- cache+ -- A B E B A N N E N N A E A <- Get All/Begin/End/None+ -- logPutStrLn $ "extendPicture " ++ show ((db `inRegion` (picRegion cache)), ((de `compare` cb) /= (de `compare` ce)))+ case (+ db `inRegion` (picRegion cache), -- Have start+ de `compare` cb /= de `compare` ce -- Have end+ ) of + ( True, True) -> return $ dropJunk cache+ ( True, False) -> append (dropJunk cache) <$> ext (mkExtentRegion ce de)+ (False, True) -> flip append cache <$> ext (mkRegion db cb)+ (False, False) -> ext (mkExtentRegion db de)+ -- ext (mkExtentRegion db de)+ where+ (db, de) = regionEnds desired+ (cb, ce) = regionEnds $ picRegion cache+ mkExtentRegion b e = mkSizeRegion b (max (b ~- e) strokeRangeExtent)+ dropJunk p = Picture -- Like dropStrokesWhile but always use db as starting point+ { picRegion = mkRegion db (regionEnd $ picRegion p) + , picStrokes = dropWhile ((db >=) . fst) (picStrokes p) + }+ append p1 p2 = Picture+ { picRegion = mkRegion (regionStart $ picRegion p1) (regionEnd $ picRegion p2)+ , picStrokes = picStrokes p1 ++ picStrokes p2+ }+ $(declareClass "YiTextStorage" "NSTextStorage") $(exportClass "YiTextStorage" "yts_" [ InstanceVariable "buffer" [t| Maybe FBuffer |] [| Nothing |]+ , InstanceVariable "editor" [t| Editor |] [| emptyEditor |]+ , InstanceVariable "window" [t| Maybe Window |] [| Nothing |] , InstanceVariable "uiStyle" [t| Maybe UIStyle |] [| Nothing |] , InstanceVariable "dictionaryCache" [t| M.Map Attributes (NSDictionary ()) |] [| M.empty |]- , InstanceVariable "pictureCacheStart" [t| Point |] [| 0 |]- , InstanceVariable "pictureCache" [t| Picture |] [| [] |]- , InstanceVariable "stringCache" [t| Maybe (NSString ()) |] [| Nothing |]+ , InstanceVariable "pictureCache" [t| (Picture, NSRange) |] [| emptyPicture |]+ , InstanceVariable "stringCache" [t| Maybe (YiLBString ()) |] [| Nothing |] , InstanceMethod 'string -- ' , InstanceMethod 'fixesAttributesLazily -- ' , InstanceMethod 'attributeAtIndexEffectiveRange -- ' , InstanceMethod 'attributesAtIndexEffectiveRange -- '+ , InstanceMethod 'attributesAtIndexLongestEffectiveRangeInRange , InstanceMethod 'replaceCharactersInRangeWithString -- '- , InstanceMethod 'setAttributesRange -- '+ , InstanceMethod 'setAttributesRange -- Disallow changing attributes+ , InstanceMethod 'addAttributesRange -- optimized to avoid needless work+ , InstanceMethod 'addAttributeValueRange -- ... , InstanceMethod 'length -- ' ]) yts_length :: YiTextStorage () -> IO CUInt yts_length slf = do -- logPutStrLn "Calling yts_length "- (fromIntegral . flip runBufferDummyWindow sizeB . fromJust) <$> slf #. _buffer+ slf #. _stringCache >>= length . fromJust yts_string :: YiTextStorage () -> IO (NSString ())-yts_string slf = do- withCache slf _stringCache (const True) $ do- s <- new _YiLBString- Just b <- slf #. _buffer- s # setIVar _str (runBufferDummyWindow b (streamB Forward 0))- castObject <$> return s+yts_string slf = castObject <$> fromJust <$> slf #. _stringCache yts_fixesAttributesLazily :: YiTextStorage () -> IO Bool yts_fixesAttributesLazily _ = return True yts_attributesAtIndexEffectiveRange :: CUInt -> NSRangePointer -> YiTextStorage () -> IO (NSDictionary ()) yts_attributesAtIndexEffectiveRange i er slf = do- picStart <- slf #. _pictureCacheStart- pic <- dropJunk <$> slf #. _pictureCache- case pic of- (q,_):_ | pos >= picStart && pos < q -> returnRange pic- _ -> returnRange =<< filterSame <$> slf # storagePicture i- where- dropJunk = dropWhile ((pos >=) . fst)- pos = fromIntegral i- returnRange [] = error "Empty picture?"- returnRange pic@((end,s):_) = do- slf # setIVar _pictureCacheStart pos- slf # setIVar _pictureCache pic- logPutStrLn $ "yts_attributesAtIndexEffectiveRange " ++ show i ++ " => " ++ show (NSRange i (fromIntegral end)) ++ " " ++ show (take 1 pic)- safePoke er (NSRange i (fromIntegral end - i))- dicts <- slf #. _dictionaryCache+ (cache, _) <- slf #. _pictureCache+ if (fromIntegral i `inRegion` picRegion cache)+ then returnEffectiveRange cache i er (mkRegionRange $ picRegion cache) slf+ else yts_attributesAtIndexLongestEffectiveRangeInRange i er (NSRange i 1) slf++yts_attributesAtIndexLongestEffectiveRangeInRange :: CUInt -> NSRangePointer -> NSRange -> YiTextStorage () -> IO (NSDictionary ())+yts_attributesAtIndexLongestEffectiveRangeInRange i er rl slf = do+ (cache, prev_rl) <- slf #. _pictureCache+ -- Since we only cache the remaining part of the rl window, we must+ -- check to ensure that we do not re-read the window all the time...+ let use_rl = if prev_rl == rl then NSRange i (nsMaxRange rl) else rl+ -- logPutStrLn $ "yts_attributesAtIndexLongestEffectiveRangeInRange " ++ show i ++ " " ++ show rl+ ed <- slf #. _editor+ full <- extendPicture (mkRangeRegion use_rl) (flip (storagePicture ed) slf) cache+ -- TODO: Only merge identical strokes when "needed"?+ returnEffectiveRange full i er rl slf++returnEffectiveRange :: Picture -> CUInt -> NSRangePointer -> NSRange -> YiTextStorage () -> IO (NSDictionary ())+returnEffectiveRange full i er rl slf = do+ pic <- return $ dropStrokesWhile ((fromIntegral i >=) . fst) full+ -- logPutStrLn $ "returnEffectiveRange " ++ show pic+ slf # setIVar _pictureCache (pic, rl)+ if nullPicture pic+ then error "Empty picture?"+ else do+ let begin = fromIntegral $ regionStart $ picRegion pic+ let (next,s) = head $ picStrokes pic+ let end = min (fromIntegral next) (nsMaxRange rl)+ len <- yts_length slf+ safePoke er (NSRange begin ((min end len) - begin)) -- Keep a cache of seen styles... usually, there should not be to many -- TODO: Have one centralized cache instead of one per text storage...- case M.lookup s dicts of- Just dict -> return dict- _ -> do- dict <- convertAttributes s- slf # setIVar _dictionaryCache (M.insert s dict dicts)- return dict+ dict <- slf # cachedDictionaryFor s+ -- TODO: Introduce some sort of cache for this...+ -- Create a new NSTextStorage to enforce Cocoa font-substitution+ str <- yts_string slf >>= substringWithRange (NSRange begin ((min end len) - begin))+ store <- _NSTextStorage # alloc >>= initWithStringAttributes str dict+ -- Extract the dictionary with adjusted fonts, and new (smaller) range+ dict2 <- store # attributesAtIndexEffectiveRange (i - begin) er+ when (er /= nullPtr) $ do+ -- If we got a range, we should offset it Offset the effective range accordingly+ NSRange b2 l2 <- peek er+ poke er (NSRange (begin + b2) l2)+ return dict2 +cachedDictionaryFor :: Attributes -> YiTextStorage () -> IO (NSDictionary ())+cachedDictionaryFor s slf = do+ dicts <- slf #. _dictionaryCache+ case M.lookup s dicts of+ Just dict -> return dict+ _ -> do+ dict <- convertAttributes s+ slf # setIVar _dictionaryCache (M.insert s dict dicts)+ return dict++ + yts_attributeAtIndexEffectiveRange :: forall t. NSString t -> CUInt -> NSRangePointer -> YiTextStorage () -> IO (ID ()) yts_attributeAtIndexEffectiveRange attr i er slf = do attr' <- haskellString attr@@ -190,16 +289,21 @@ safePokeFullRange >> return nil "NSLanguage" -> do safePokeFullRange >> return nil+ "NSLink" -> do+ safePokeFullRange >> return nil "NSParagraphStyle" -> do -- TODO: Adjust line break property... safePokeFullRange >> castObject <$> defaultParagraphStyle _NSParagraphStyle "NSBackgroundColor" -> do- ~((s,a):_) <- onlyBg <$> slf # storagePicture i- safePoke er (NSRange i (fromIntegral s - i))+ -- safePokeFullRange >> castObject <$> blackColor _NSColor+ len <- yts_length slf+ ed <- slf #. _editor+ ~((s,a):_) <- onlyBg <$> picStrokes <$> slf # storagePicture ed (mkSizeRegion (fromIntegral i) strokeRangeExtent)+ safePoke er (NSRange i ((min len (fromIntegral s)) - i)) castObject <$> getColor False (background a) _ -> do -- TODO: Optimize the other queries as well (if needed)- logPutStrLn $ "Unoptimized yts_attributeAtIndexEffectiveRange " ++ attr' ++ " at " ++ show i+ -- logPutStrLn $ "Unoptimized yts_attributeAtIndexEffectiveRange " ++ attr' ++ " at " ++ show i super slf # attributeAtIndexEffectiveRange attr i er where safePokeFullRange = do@@ -212,6 +316,10 @@ yts_replaceCharactersInRangeWithString _ _ _ = return () yts_setAttributesRange :: forall t. NSDictionary t -> NSRange -> YiTextStorage () -> IO () yts_setAttributesRange _ _ _ = return ()+yts_addAttributesRange :: NSDictionary t -> NSRange -> YiTextStorage () -> IO ()+yts_addAttributesRange _ _ _ = return ()+yts_addAttributeValueRange :: NSString t -> ID () -> NSRange -> YiTextStorage () -> IO ()+yts_addAttributeValueRange _ _ _ _ = return () -- | Remove element x_i if f(x_i,x_(i+1)) is true filter2 :: (a -> a -> Bool) -> [a] -> [a]@@ -220,17 +328,13 @@ filter2 f (x1:x2:xs) = (if f x1 x2 then id else (x1:)) $ filter2 f (x2:xs) --- | Merge needless style-span breaks-filterSame :: Picture -> Picture-filterSame = filter2 ((==) `on` snd)- -- | Keep only the background information-onlyBg :: Picture -> Picture+onlyBg :: [PicStroke] -> [PicStroke] onlyBg = filter2 ((==) `on` (background . snd)) -- | Get a picture where each component (p,style) means apply the style -- up until the given point p.-paintCocoaPicture :: UIStyle -> Point -> Picture -> Picture+paintCocoaPicture :: UIStyle -> Point -> [PicStroke] -> [PicStroke] paintCocoaPicture sty end = tail . stylesift (baseAttributes sty) where -- Turn a picture of use style from p into a picture of use style until p@@ -239,58 +343,80 @@ -- | A version of poke that does nothing if p is null. safePoke :: (Storable a) => Ptr a -> a -> IO ()-safePoke p x = if p == nullPtr then return () else poke p x+safePoke p x = when (p /= nullPtr) (poke p x) -- | Execute strokeRangesB on the buffer, and update the buffer -- so that we keep around cached syntax information...-storagePicture :: CUInt -> YiTextStorage () -> IO Picture-storagePicture i slf = do+-- We assume that the incoming region provide character-indices,+-- and we need to find out the corresponding byte-indices+storagePicture :: Editor -> Region -> YiTextStorage () -> IO Picture+storagePicture ed r slf = do Just sty <- slf #. _uiStyle Just buf <- slf #. _buffer- logPutStrLn $ "storagePicture " ++ show i- return $ bufferPicture sty buf (fromIntegral i)+ Just win <- slf #. _window+ -- logPutStrLn $ "storagePicture " ++ show i+ return $ bufferPicture ed sty buf win r -bufferPicture :: UIStyle -> FBuffer -> Point -> Picture-bufferPicture sty buf p =- let r = mkSizeRegion p strokeRangeExtent in- paintCocoaPicture sty (regionEnd r) $- runBufferDummyWindow buf (attributesPictureB sty Nothing r [])+byteToCharPicture :: Point -> [Point] -> [PicStroke] -> [PicStroke]+byteToCharPicture o [] xs = [(o,a) | (_,a) <- take 1 xs]+byteToCharPicture _ _ [] = []+byteToCharPicture o (p:ps) ((i,a):xs)+ | p < i = byteToCharPicture (succ o) ps ((i,a):xs)+ | otherwise = (o,a) : byteToCharPicture o (p:ps) xs +bufferPicture :: Editor -> UIStyle -> FBuffer -> Window -> Region -> Picture+bufferPicture ed sty buf win r =+ let (r',is) = fst $ runBuffer win buf ((,) <$> byteRegionB r <*> indexStreamRegionB r)+ in Picture+ { picRegion = r+ , picStrokes =+ paintCocoaPicture sty (regionEnd r) $+ byteToCharPicture (regionStart r) is $+ (fst $ runBuffer win buf (attributesPictureB sty (regex ed) r' []))+ }+ type TextStorage = YiTextStorage () initializeClass_TextStorage :: IO () initializeClass_TextStorage = do initializeClass_YiLBString initializeClass_YiTextStorage -applyUpdate :: YiTextStorage () -> Update -> IO ()-applyUpdate buf (Insert p _ s) =+applyUpdate :: YiTextStorage () -> FBuffer -> Update -> IO ()+applyUpdate buf b (Insert p _ s) =+ let p' = runBufferDummyWindow b (charIndexB p) in buf # editedRangeChangeInLength nsTextStorageEditedCharacters- (NSRange (fromIntegral p) 0) (fromIntegral $ LB.length s)+ (NSRange (fromIntegral p') 0) (fromIntegral $ LB.length s) -applyUpdate buf (Delete p _ s) =- let len = LB.length s in+applyUpdate buf b (Delete p _ s) =+ let (p', len) = (runBufferDummyWindow b (charIndexB p), LB.length s) in buf # editedRangeChangeInLength nsTextStorageEditedCharacters- (NSRange (fromIntegral p) (fromIntegral len)) (fromIntegral (negate len))+ (NSRange (fromIntegral p') (fromIntegral len)) (fromIntegral (negate len)) -newTextStorage :: UIStyle -> FBuffer -> IO TextStorage-newTextStorage sty b = do+newTextStorage :: UIStyle -> FBuffer -> Window -> IO TextStorage+newTextStorage sty b w = do buf <- new _YiTextStorage buf # setIVar _buffer (Just b)+ buf # setIVar _window (Just w) buf # setIVar _uiStyle (Just sty)+ s <- new _YiLBString+ s # setIVar _str (runBufferDummyWindow b (streamB Forward 0))+ buf # setIVar _stringCache (Just s) buf # setMonospaceFont return buf -setTextStorageBuffer :: FBuffer -> TextStorage -> IO ()-setTextStorageBuffer buf storage = do+setTextStorageBuffer :: Editor -> FBuffer -> TextStorage -> IO ()+setTextStorageBuffer ed buf storage = do storage # beginEditing- when (not $ null $ pendingUpdates buf) $ do- mapM_ (applyUpdate storage) [u | TextUpdate u <- pendingUpdates buf]- storage # setIVar _pictureCache []+ Just s <- storage #. _stringCache+ s # setIVar _str (runBufferDummyWindow buf (streamB Forward 0)) storage # setIVar _buffer (Just buf)- storage # setIVar _stringCache Nothing+ storage # setIVar _editor ed+ when (not $ null $ pendingUpdates buf) $ do+ mapM_ (applyUpdate storage buf) [u | TextUpdate u <- pendingUpdates buf]+ storage # setIVar _pictureCache emptyPicture storage # endEditing visibleRangeChanged :: NSRange -> TextStorage -> IO () visibleRangeChanged range storage = do+ storage # setIVar _pictureCache emptyPicture storage # editedRangeChangeInLength nsTextStorageEditedAttributes range 0- storage # setIVar _pictureCache []
Yi/UI/Cocoa/TextView.hs view
@@ -19,45 +19,148 @@ , visibleRange )where +import Prelude ()+import Yi.Prelude+import Yi.String import Yi.Buffer hiding (runBuffer)+import Yi.UI.Cocoa.Utils -import Foundation-import AppKit+-- Specify Cocoa imports explicitly, to avoid name-clashes.+-- Since the number of functions recognized by HOC varies+-- between revisions, this seems like the safest choice.+import HOC+import Foundation (+ NSPoint(..),NSRange(..),nsMinY,nsWidth,nsOffsetRect,NSArray,+ addObject,haskellString,NSMutableArray,NSValue,+ _NSMutableArray,array,addObjectsFromArray,rangeValue)+import AppKit (+ NSSelectionAffinity,characterRangeForGlyphRangeActualGlyphRange,+ glyphRangeForBoundingRectInTextContainer,layoutManager,textContainer,+ textContainerOrigin,visibleRect,frame,verticalScroller,NSTextView,+ NSTextViewClass,setSelectedRangesAffinityStillSelecting,NSScrollView,+ NSScrollViewClass,tile,setFrameOrigin,performDragOperation,+ acceptableDragTypes,nsStringPboardType,stringForType,NSPasteboard,+ convertPointFromView,availableTypeFromArray,_NSPasteboard,+ typesFilterableTo,nsFilenamesPboardType,propertyListForType,+ glyphIndexForPointInTextContainerFractionOfDistanceThroughGlyph) import qualified AppKit.NSScrollView (contentView) import Foreign import Foreign.C +-- TODO: The correct way of doing this would be to add the+-- protocol constraints on the performDragOperation+-- parameter, but for whatever reason, HOC doesn't+-- do this, so we use this hack to work around it...+$(declareRenamedSelector "draggingLocation" "draggingLocation" [t| IO NSPoint |])+$(declareRenamedSelector "draggingSource" "draggingSource" [t| IO (ID ()) |])+$(declareRenamedSelector "draggingPasteboard" "draggingPasteboard" [t| IO (NSPasteboard ()) |])+instance Has_draggingPasteboard (ID t)+instance Has_draggingSource (ID t)+instance Has_draggingLocation (ID t)+_silenceWarning :: (+ ImpType_draggingPasteboard a b,+ ImpType_draggingSource c d,+ ImpType_draggingLocation e f)+_silenceWarning = undefined++ $(declareClass "YiTextView" "NSTextView") $(exportClass "YiTextView" "ytv_" [ InstanceVariable "runBuffer" [t| BufferM () -> IO () |] [| \_ -> return () |]- , InstanceVariable "selectingPosition" [t| Maybe CUInt |] [| Nothing |]- , InstanceMethod 'setSelectedRangeAffinityStillSelecting -- '+ , InstanceVariable "selectingPosition" [t| Maybe Point |] [| Nothing |]+ , InstanceMethod 'setSelectedRangesAffinityStillSelecting -- '+ , InstanceMethod 'acceptableDragTypes+ , InstanceMethod 'performDragOperation ]) -- | Intercept mouse selection so that we can update Yi's selection -- according to how Cocoa wants it.-ytv_setSelectedRangeAffinityStillSelecting :: NSRange -> NSSelectionAffinity -> Bool -> YiTextView () -> IO ()-ytv_setSelectedRangeAffinityStillSelecting r@(NSRange p1 l) a b v = do+ytv_setSelectedRangesAffinityStillSelecting :: NSArray () -> NSSelectionAffinity -> Bool -> YiTextView () -> IO ()+ytv_setSelectedRangesAffinityStillSelecting rs a b v = do+ hrs <- fmap castObject <$> haskellList rs :: IO [NSValue ()]+ r <- foldl1 unionRegion <$> fmap mkRangeRegion <$> mapM rangeValue hrs :: IO Region p <- v #. _selectingPosition case (b, p) of (True, Nothing) -> do -- Assume that the initial indication gives starting position- v # setIVar _selectingPosition (Just p1)+ v # setIVar _selectingPosition (Just $ regionStart r) (False, Just p0) -> do v # setIVar _selectingPosition Nothing runbuf <- v #. _runBuffer runbuf $ do- setVisibleSelection (l /= 0)- setSelectionMarkPointB (fromIntegral p0)- moveTo (fromIntegral $ if p1 == p0 then p1 + l else p1)+ setVisibleSelection (regionSize r /= 0)+ byteIndexB p0 >>= setSelectionMarkPointB+ byteIndexB (if regionStart r == p0 then regionEnd r else regionStart r) >>= moveTo _ -> do -- Ignore intermediate updates (Cocoa buffers events until selection finishes) -- Ignore direct updates (to avoid having to detect "our" updates) return () - super v # setSelectedRangeAffinityStillSelecting r a b+ super v # setSelectedRangesAffinityStillSelecting rs a b++ytv_acceptableDragTypes :: YiTextView () -> IO (NSArray ())+ytv_acceptableDragTypes _ = do+ ar <- castObject <$> _NSMutableArray # array :: IO (NSMutableArray ())+ _NSPasteboard # typesFilterableTo nsStringPboardType >>=+ flip addObjectsFromArray ar+ ar # addObject nsFilenamesPboardType+ return (castObject ar)++-- Implement support for drag and drop...+ytv_performDragOperation :: ID t -> YiTextView () -> IO Bool+ytv_performDragOperation dragInfo slf = do+ pb <- dragInfo # draggingPasteboard++ ty <- slf # ytv_acceptableDragTypes >>= flip availableTypeFromArray pb+ + when (ty /= nil) $ do+ str <-+ if ty == nsFilenamesPboardType+ then unlines' <$> + (pb # propertyListForType ty >>= (haskellList.castObject) >>= mapM (haskellString.castObject))+ else pb # stringForType ty >>= haskellString++ src <- dragInfo # draggingSource+ -- Apparently, the selection only looks as if it was updated...+ -- we would have to use draggingLocation to figure out where+ -- the new text should go. Which means that we need to get back+ -- our old trick for translating a mouse-position to a text-position.++ -- TODO: Convert ip from a character index to a buffer position (utf8)+ pIns' <- dragInfo # draggingLocation >>= flip charAtMouse slf++ runbuf <- slf #. _runBuffer+ runbuf $ do+ hasSel <- getA highlightSelectionA+ rSel <- if hasSel && src == (castObject slf) then getSelectRegionB else return emptyRegion+ pIns <- byteIndexB (fromIntegral pIns')++ moveTo $ fromIntegral pIns+ -- To not affect positions we make the "latter" modification first+ -- Note that there will be no drag operation if they overlap...+ if regionStart rSel < fromIntegral pIns+ then insertN str >> deleteRegionB rSel+ else deleteRegionB rSel >> insertN str+ + return (ty /= nil)++-- | Compute the character index of the specified mouse position+charAtMouse :: NSPoint -> YiTextView () -> IO CUInt+charAtMouse p slf = do+ -- Determine the text-relative coordinate+ container <- slf # textContainer+ NSPoint ex ey <- slf # convertPointFromView p nil+ NSPoint ox oy <- slf # textContainerOrigin+ let mouse = NSPoint (ex - ox) (ey - oy)+ -- Determine the index+ layout <- slf # layoutManager+ pf <- malloc -- I miss stack variables from C... =P+ index <- layout # glyphIndexForPointInTextContainerFractionOfDistanceThroughGlyph mouse container pf+ fract <- peek pf+ free pf+ return $ if (fract > 0.5) then index + 1 else index -- | Compute the currently visible text range in the view visibleRange :: YiTextView () -> IO NSRange
Yi/UI/Cocoa/Utils.hs view
@@ -8,12 +8,25 @@ import Prelude hiding (init) import Yi.Debug+import Yi.Region import Yi.Style import Control.Applicative -import Foundation hiding (new)-import AppKit hiding (dictionary)+-- Specify Cocoa imports explicitly, to avoid name-clashes.+-- Since the number of functions recognized by HOC varies+-- between revisions, this seems like the safest choice.+import HOC+import Foundation (+ NSDictionary,NSMutableDictionary,NSObject,NSObject_,+ _NSMutableDictionary,alloc,autorelease,catchNS,description,+ haskellString,retain,setValueForKey,dictionary,init,+ objectEnumerator,nextObject,NSArray,NSRange(..))+import AppKit (+ Has_setFont,NSColor,_NSColor,_NSFont,blackColor,+ colorWithDeviceRedGreenBlueAlpha,nsBackgroundColorAttributeName,+ nsFontAttributeName,nsForegroundColorAttributeName,setFont,+ userFixedPitchFontOfSize,whiteColor) logNSException :: String -> IO () -> IO () logNSException str act =@@ -58,18 +71,10 @@ -- | Convert a Yi color into a Cocoa color getColor :: Bool -> Color -> IO (NSColor ()) getColor fg Default = if fg then _NSColor # blackColor else _NSColor # whiteColor-getColor fg Reverse = if fg then _NSColor # whiteColor else _NSColor # blackColor getColor _g (RGB r g b) = let conv = (/255) . fromIntegral in _NSColor # colorWithDeviceRedGreenBlueAlpha (conv r) (conv g) (conv b) 1.0 --- Debugging helpers--{---data Hierarchy = View String NSRect [Hierarchy]- deriving Show- haskellList :: forall t1. NSArray t1 -> IO [ID ()] haskellList a = a # objectEnumerator >>= helper where@@ -78,6 +83,20 @@ if e == nil then return [] else helper enum >>= return . (e :)++mkRangeRegion :: NSRange -> Region+mkRangeRegion (NSRange i l) = mkSizeRegion (fromIntegral i) (fromIntegral l)++mkRegionRange :: Region -> NSRange+mkRegionRange r = NSRange (fromIntegral $ regionStart r) (fromIntegral $ regionSize r)++{-++-- Debugging helpers++data Hierarchy = View String NSRect [Hierarchy]+ deriving Show+ mkHierarchy :: forall t. NSView t -> IO Hierarchy mkHierarchy v = do
Yi/UI/Gtk.hs view
@@ -275,7 +275,8 @@ p0 <- withGivenBuffer0 b $ pointB if p1 == p0 then withGivenBuffer0 b $ setVisibleSelection False- else do txt <- withGivenBuffer0 b $ do setMarkPointB staticSelMark p1+ else do txt <- withGivenBuffer0 b $ do m <- selMark <$> askMarks+ setMarkPointB m p1 let [i,j] = sort [p1,p0] nelemsB' (j~-i) i setRegE txt@@ -406,7 +407,7 @@ gtkBuf <- getGtkBuffer ui buf let (Point p0) = fst $ runBuffer win buf pointB- let (Point p1) = fst $ runBuffer win buf (getMarkPointB staticSelMark)+ let (Point p1) = fst $ runBuffer win buf (getMarkPointB =<< selMark <$> askMarks) let (showSel) = fst $ runBuffer win buf (getA highlightSelectionA) i <- textBufferGetIterAtOffset gtkBuf p0 if showSel @@ -445,7 +446,7 @@ styleToTag :: UI -> Attributes -> IO [TextTag] styleToTag ui a = case a of- (Attributes f b) -> sequence [tagOf textTagForeground f, tagOf textTagBackground b]+ (Attributes f b _reverse) -> sequence [tagOf textTagForeground f, tagOf textTagBackground b] where tagOf attr col = do let fgText = colorToText col@@ -513,7 +514,8 @@ replaceTagsIn ui (mkRegion 0 sz) b buf return buf -toColor :: Bool -> Style.Color -> Gtk.Color-toColor fg Default = let c = if fg then 0xff else 0 in Color c c c-toColor fg Reverse = let c = if fg then 0 else 0xff in Color c c c-toColor _g (RGB r g b) = Color (fromIntegral r * 0xff) (fromIntegral g * 0xff) (fromIntegral b * 0xff)+-- | Convert a color to Gtk counterpart. +toColor :: Bool -> -- ^ is the color intended to be used as Foreground?+ Style.Color -> Gtk.Color+toColor fg Default = let c = if fg then 0xffff else 0 in Color c c c+toColor _fg (RGB r g b) = Color (fromIntegral r * 0xff) (fromIntegral g * 0xff) (fromIntegral b * 0xff)
Yi/UI/Gtk/ProjectTree.hs view
@@ -66,7 +66,7 @@ icoSetupScript MView.cellLayoutSetAttributes col1 renderer1 projectStore $ \row -> [MView.cellPixbuf := itemIcon icos row] - MView.cellLayoutSetAttributes col2 renderer2 projectStore $ \row -> [MView.cellText := itemDisplayName row] + MView.cellLayoutSetAttributes col2 renderer2 projectStore $ \row -> [MView.cellText := itemName row] MView.treeViewAppendColumn projectTree col1 MView.treeViewAppendColumn projectTree col2 @@ -123,11 +123,3 @@ moduleIcon icos ExposedModule icoE _ = icoE icos moduleIcon icos HiddenModule _ icoH = icoH icos -itemDisplayName item = - let pkg_id = PackageIdentifier (itemName item) (itemVersion item) - - disp_name = case item of - ProjectItem{} -> display pkg_id - PackageItem{} -> display pkg_id - item -> itemName item - in disp_name
Yi/UI/Gtk/Utils.hs view
@@ -1,17 +1,17 @@--- --- Copyright (c) Krasimir Angelov 2008. --- --- Random GTK utils --- - -module Yi.UI.Gtk.Utils where - -import Paths_yi -import System.FilePath -import Graphics.UI.Gtk - -loadIcon :: FilePath -> IO Pixbuf -loadIcon fpath = do - datadir <- getDataDir - icoProject <- pixbufNewFromFile (datadir </> "art" </> fpath) - pixbufAddAlpha icoProject (Just (0,255,0)) +--+-- Copyright (c) Krasimir Angelov 2008.+--+-- Random GTK utils+--++module Yi.UI.Gtk.Utils where++import Paths_yi+import System.FilePath+import Graphics.UI.Gtk++loadIcon :: FilePath -> IO Pixbuf+loadIcon fpath = do+ datadir <- getDataDir+ icoProject <- pixbufNewFromFile (datadir </> "art" </> fpath)+ pixbufAddAlpha icoProject (Just (0,255,0))
Yi/UI/Pango.hs view
@@ -7,7 +7,7 @@ module Yi.UI.Pango (start) where -import Prelude (filter, map, round, length, take, FilePath, (/), subtract, zipWith)+import Prelude (filter, map, round, length, take, FilePath, (/), zipWith) import Yi.Prelude import Yi.Buffer import qualified Yi.Editor as Editor@@ -27,10 +27,11 @@ import Control.Monad.Reader (liftIO, when, MonadIO) import Control.Monad.State (gets) +import Data.Prototype import Data.Function import Data.Foldable import Data.IORef-import Data.List (nub, findIndex)+import Data.List (nub, findIndex, zip, drop) import Data.Maybe import Data.Traversable import qualified Data.Map as M@@ -87,6 +88,8 @@ Nothing -> return () return f +askBuffer w b f = fst $ runBuffer w b f+ -- | Initialise the ui start :: UIBoot start cfg ch outCh _ed = do@@ -219,7 +222,7 @@ syncWin :: Editor -> Window -> WinInfo -> IO WinInfo syncWin e w wi = do let b = findBufferWith (bufkey w) e- reg = runBufferDummyWindow b winRegionB+ reg = askBuffer w b winRegionB logPutStrLn $ "Updated one: " ++ show w ++ " to " ++ show reg writeRef (shownRegion wi) reg return (wi {coreWin = w})@@ -269,11 +272,11 @@ case (eventClick event, eventButton event) of (SingleClick, LeftButton) -> do focusWindow- withGivenBuffer0 b $ moveTo p1+ withGivenBufferAndWindow0 (coreWin w) b $ moveTo p1 (SingleClick, _) -> focusWindow (ReleaseClick, MiddleButton) -> do txt <- getRegE- withGivenBuffer0 b $ do+ withGivenBufferAndWindow0 (coreWin w) b $ do pointB >>= setSelectionMarkPointB moveTo p1 insertN txt@@ -297,7 +300,8 @@ txt <- withBuffer0 $ do if p0 /= p1 then Just <$> do- setMarkPointB staticSelMark p0+ m <- selMark <$> askMarks+ setMarkPointB m p0 moveTo p1 setVisibleSelection True readRegionB =<< getSelectRegionB@@ -345,7 +349,7 @@ return (castToBox vb) sig <- newIORef =<< (v `onExpose` render e ui b win)- rRef <- newIORef (runBufferDummyWindow b winRegionB)+ rRef <- newIORef (askBuffer w b winRegionB) context <- widgetCreatePangoContext v layout <- layoutEmpty context layoutSetWrap layout WrapAnywhere@@ -416,12 +420,13 @@ reg <- readRef (shownRegion w) drawWindow <- widgetGetDrawWindow $ textview w (width, height) <- widgetGetSize $ textview w+ let win = coreWin w let [width', height'] = map fromIntegral [width, height] let metrics = winMetrics w layout = winLayout w winh = round (height' / (ascent metrics + descent metrics)) - let (point, text) = runBufferDummyWindow b $ do+ let (point, text) = askBuffer win b $ do numChars <- winEls (regionStart reg) winh (,) <$> pointB@@ -440,9 +445,9 @@ then return r' else do logPutStrLn $ "out!"- let newTos = runBufferDummyWindow b $ do+ let newTos = askBuffer win b $ do indexOfSolAbove (winh `div` 2)- text' = runBufferDummyWindow b $ do+ text' = askBuffer win b $ do numChars <- winEls newTos winh nelemsB' numChars newTos layoutSetText layout text'@@ -454,16 +459,15 @@ logPutStrLn $ "updated: " ++ show r'' -- add color attributes.- let (strokes,selectReg,selVisible) = runBufferDummyWindow b $ (,,)- <$> strokesRangesB (regex e) r''- <*> getSelectRegionB- <*> getA highlightSelectionA- - regInWin = fmapRegion (subtract (regionStart r'')) (intersectRegion selectReg r'')- allAttrs = (if selVisible - then (AttrBackground (fromPoint (regionStart regInWin)) (fromPoint (regionEnd regInWin - 1))- (Color 50000 50000 maxBound) :)- else id) []+ let picture = askBuffer win b $ attributesPictureAndSelB sty (regex e) r''+ sty = extractValue $ configTheme (uiConfig ui)+ strokes = [(start,s,end) | ((start, s), end) <- zip picture (drop 1 (map fst picture) ++ [regionEnd r'']),+ s /= emptyAttributes]+ rel p = fromIntegral (p - regionStart r'')+ allAttrs = [gen (rel p1) (rel p2) (mkCol col) + | (p1,Attributes fg bg _rv,p2) <- strokes, + (gen,col) <- zip [AttrForeground, AttrBackground] [fg,bg],+ col /= Default] layoutSetAttributes layout allAttrs @@ -487,7 +491,7 @@ return $ do let updWin w r = do withGivenBufferAndWindow0 w (bufkey w) $ do- Just (WinMarks f _ _ t) <- getMarks w+ Just (MarkSet f _ _ t) <- getMarks w setMarkPointB f (regionStart r) setMarkPointB t (regionEnd r) -- TODO: also update height and bos.@@ -499,7 +503,6 @@ mkCol :: Yi.Style.Color -> Gtk.Color mkCol Default = Color 0 0 0-mkCol Reverse = Color maxBound maxBound maxBound mkCol (RGB x y z) = Color (fromIntegral x * 256) (fromIntegral y * 256) (fromIntegral z * 256)
Yi/UI/TabBar.hs view
@@ -4,30 +4,18 @@ import Yi.WindowSet import Yi.Editor (Editor(..) ,findBufferWith)-import Yi.Style data TabDescr = TabDescr { tabText :: String,- tabAttributes :: Attributes, tabInFocus :: Bool } type TabBarDescr = WindowSet TabDescr -tabBarDescr :: Editor -> Int -> UIStyle -> TabBarDescr-tabBarDescr editor maxWidth uiStyle = - -- TODO: Use different styles for oofTabStyle and ifTabStyle. - -- I tried using modeline and modelineFocused but this had an undesired - -- effect on the mode line. - CROC- let oofTabStyle = modelineAttributes uiStyle- ifTabStyle = modelineAttributes uiStyle- hintForTab tab = hint- where currentBufferName = name $ findBufferWith (bufkey $ current tab) editor- hint = if length currentBufferName > maxWidth- then take (maxWidth - 3) currentBufferName ++ "..."- else currentBufferName- tabDescr (tab,True) = TabDescr (hintForTab tab) ifTabStyle True- tabDescr (tab,False) = TabDescr (hintForTab tab) oofTabStyle False+tabBarDescr :: Editor -> TabBarDescr+tabBarDescr editor = + let hintForTab tab = name $ findBufferWith (bufkey $ current tab) editor+ tabDescr (tab,True) = TabDescr (hintForTab tab) True+ tabDescr (tab,False) = TabDescr (hintForTab tab) False in fmap tabDescr (withFocus $ tabs editor)-
Yi/UI/Utils.hs view
@@ -10,7 +10,7 @@ import Control.Arrow (second) import Data.Monoid import Yi.Style-import Yi.Syntax (Stroke)+import Control.Monad.State (gets) -- | return index of Sol on line @n@ above current line indexOfSolAbove :: Int -> BufferM Point indexOfSolAbove n = savingPointB $ do@@ -64,3 +64,9 @@ (extraLayers ++) <$> strokesRangesB mexp region +attributesPictureAndSelB :: UIStyle -> Maybe SearchExp -> Region -> BufferM [(Point,Attributes)]+attributesPictureAndSelB sty mexp region = do+ selReg <- getSelectRegionB+ showSel <- getA highlightSelectionA+ let extraLayers = if showSel then [[(regionStart selReg, selectedStyle, regionEnd selReg)]] else []+ attributesPictureB sty mexp region extraLayers
Yi/UI/Vty.hs view
@@ -24,7 +24,7 @@ import Data.Monoid import Data.Traversable import System.Exit-import System.Posix.Signals ( raiseSignal, sigTSTP )+import System.Posix.Signals (raiseSignal, sigTSTP) import Yi.Buffer import Yi.Config import Yi.Editor@@ -44,24 +44,17 @@ import Yi.UI.Utils import Yi.UI.TabBar -------------------------------------------------------------------------- data Rendered = - Rendered {- picture :: !Image -- ^ the picture currently displayed.- ,cursor :: !(Maybe (Int,Int)) -- ^ cursor point on the above+ 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 -- ^ Copy of the editor state, local to the UI- ,config :: Config+data UI = UI { vty :: Vty -- ^ Vty+ , scrsize :: IORef (Int,Int) -- ^ screen size+ , uiThread :: ThreadId+ , uiRefresh :: MVar ()+ , uiEditor :: IORef Editor -- ^ Copy of the editor state, local to the UI+ , config :: Config } mkUI :: UI -> Common.UI@@ -187,75 +180,55 @@ logPutStrLn "refreshing screen." (yss,xss) <- readRef (scrsize ui) let ws' = computeHeights (yss - tabBarHeight) ws- cmd = statusLine e+ (cmd, cmdSty) = statusLineInfo e renderSeq = fmap (scrollAndRenderWindow (configUI $ config ui) xss) (WS.withFocus ws') (e', renders) = runEditor (config ui) (sequence renderSeq) e let startXs = scanrT (+) windowStartY (fmap height ws') wImages = fmap picture renders- statusBarStyle = baseAttributes $ configStyle $ configUI $ config $ ui+ statusBarStyle = ((appEndo <$> cmdSty) <*> baseAttributes) $ configStyle $ configUI $ config $ ui tabBarImages = renderTabBar e' ui xss WS.debug "Drawing: " ws' logPutStrLn $ "startXs: " ++ show startXs Vty.update (vty $ ui) - pic {pImage = vertcat tabBarImages - <->- vertcat (toList wImages) - <-> - withAttributes statusBarStyle (take xss $ cmd ++ repeat ' '),- pCursor = case cursor (WS.current renders) of- Just (y,x) -> Cursor x (y + WS.current startXs) - -- Add the position of the window to the position of the cursor- Nothing -> NoCursor- -- This case can occur if the user resizes the window. - -- Not really nice, but upon the next refresh the cursor will show.- }+ pic { pImage = vertcat tabBarImages+ <->+ vertcat (toList wImages) + <-> + withAttributes statusBarStyle (take xss $ cmd ++ repeat ' ')+ , pCursor = case cursor (WS.current renders) of+ Just (y,x) -> Cursor x (y + WS.current startXs) + -- Add the position of the window to the position of the cursor+ Nothing -> NoCursor+ -- This case can occur if the user resizes the window. + -- Not really nice, but upon the next refresh the cursor will show.+ } return e' -{- Produces a possible empty list of images that represent the tab bar.- - The current tab bar image is basic: A single horizontal line divided into a number of segments- - equal to the number of tabs. Plus maybe a bit extra to make up for a screen width that is not a- - multiple of the number of tabs.- - The tab current in focus is indicated by a segment of spaces. - - While the out of focus tabs are all segments filled with # characters.- - - - TODO: Provide a hint as to what the tabs contain.- - TODO: If there are too many tabs to be contained on a single line spill over onto the next line.- -}+-- | Construct images for the tabbar if at least one tab exists. renderTabBar :: Editor -> UI -> Int -> [Image]-renderTabBar e ui xss = - let tabCount = WS.size $ tabs e- in if tabCount > 1- then - let tabWidth = xss `div` tabCount- descr = tabBarDescr e (tabWidth - 5) (configStyle $ configUI $ config $ ui)- tabImages = fmap (tabToVtyImage tabWidth) descr- -- If the screen width is not a multiple of the tab width then characters have to be- -- added to make them the same. Otherwise Vty will error out when trying to- -- vertically concat two images with different widths.- extraCount = xss - (tabWidth * WS.size tabImages)- extraStyle = modelineAttributes $ configStyle $ configUI $ config $ ui- extraImage = withAttributes extraStyle $ replicate extraCount '#'- finalImage = if extraCount /= 0- then foldr (<|>) extraImage tabImages- else foldr1 (<|>) tabImages- in [finalImage]- else []- where - -- From an abstract description of a tab to a VTY image of the tab.- tabToVtyImage width (TabDescr txt sty inFocus) = - let pad = replicate (width - length txt - 5) ' '- spacers = if inFocus then (">>", "<<") else (" ", " ")- in withAttributes sty $ (fst spacers) ++ txt ++ (snd spacers) ++ pad ++ "|"+renderTabBar e ui xss =+ if tabCount > 1+ then [tabImages <|> extraImage]+ else []+ where tabCount = WS.size $ tabs e + tabImages = foldr1 (<|>) $ fmap tabToVtyImage $ tabBarDescr e+ extraImage = withAttributes (tabBarAttributes uiStyle) (replicate (xss-totalTabWidth) ' ')++ totalTabWidth = imgWidth tabImages+ uiStyle = configStyle $ configUI $ config $ ui+ tabTitle text = " " ++ text ++ " "+ tabAttributes f = appEndo ((if f then tabInFocusStyle else tabNotFocusedStyle) uiStyle) (tabBarAttributes uiStyle)+ tabToVtyImage (TabDescr text inFocus) = withAttributes (tabAttributes inFocus) (tabTitle text)+ 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, and return a rendered wiew of the window. scrollAndRenderWindow :: UIConfig -> Int -> (Window, Bool) -> EditorM Rendered@@ -291,21 +264,19 @@ ground = baseAttributes sty wsty = attributesToAttr ground attr eofsty = appEndo (eofStyle sty) ground- (selReg, _) = runBuffer win b getSelectRegionB (point, _) = runBuffer win b pointB (eofPoint, _) = runBuffer win b sizeB region = mkSizeRegion fromMarkPoint (Size (w*h')) -- Work around a problem with the mini window never displaying it's contents due to a -- fromMark that is always equal to the end of the buffer contents.- (Just (WinMarks fromM _ _ toM), _) = runBuffer win b (getMarks win)+ (Just (MarkSet fromM _ _ toM), _) = runBuffer win b (getMarks win) fromMarkPoint = if notMini then fst $ runBuffer win b (getMarkPointB fromM) else Point 0 (text, _) = runBuffer win b (indexedStreamB Forward fromMarkPoint) -- read chars from the buffer, lazily- (showSel, _) = runBuffer win b (gets highlightSelection)- extraLayers = if showSel then [[(regionStart selReg, selectedStyle, regionEnd selReg)]] else []- (picture, _) = runBuffer win b (attributesPictureB sty mre region extraLayers)- colors = map (second (($ attr) . attributesToAttr)) picture+ + (attributes, _) = runBuffer win b $ attributesPictureAndSelB sty mre region + colors = map (second (($ attr) . attributesToAttr)) attributes bufData = -- trace (unlines (map show text) ++ unlines (map show $ concat strokes)) $ paintChars attr colors text tabWidth = tabSize . fst $ runBuffer win b indentSettingsB@@ -352,14 +323,14 @@ -- fill lines with blanks, so the selection looks ok. rendered_lines = map fillColorLine lns0- colorChar (c, (a, aPoint)) = renderChar a c+ colorChar (c, (a, _aPoint)) = renderChar a c fillColorLine :: [(Char, (Vty.Attr, Point))] -> Image fillColorLine [] = renderHFill attr ' ' w fillColorLine l = horzcat (map colorChar l) <|> renderHFill a ' ' (w - length l)- where (_,(a,x)) = last 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@@ -385,7 +356,6 @@ withAttributes :: Attributes -> String -> Image withAttributes sty str = renderBS (attributesToAttr sty attr) (B.pack str) - ------------------------------------------------------------------------ userForceRefresh :: UI -> IO ()@@ -427,44 +397,34 @@ ------------------------------------------------------------------------ ------ Combine attribute with another attribute----boldA, reverseA, nullA :: Vty.Attr -> Vty.Attr-boldA = setBold-reverseA = setRV-nullA = id--------------------------------------------------------------------------- -- | Convert a Yi Attr into a Vty attribute change. colorToAttr :: (Vty.Attr -> Vty.Attr) -> (Vty.Color -> Vty.Attr -> Vty.Attr) -> Vty.Color -> Style.Color -> (Vty.Attr -> Vty.Attr) colorToAttr bold set unknown c = case c of - RGB 0 0 0 -> nullA . set Vty.black+ RGB 0 0 0 -> id . set Vty.black RGB 128 128 128 -> bold . set Vty.black- RGB 139 0 0 -> nullA . set Vty.red+ RGB 139 0 0 -> id . set Vty.red RGB 255 0 0 -> bold . set Vty.red- RGB 0 100 0 -> nullA . set Vty.green+ RGB 0 100 0 -> id . set Vty.green RGB 0 128 0 -> bold . set Vty.green- RGB 165 42 42 -> nullA . set Vty.yellow+ RGB 165 42 42 -> id . set Vty.yellow RGB 255 255 0 -> bold . set Vty.yellow- RGB 0 0 139 -> nullA . set Vty.blue+ RGB 0 0 139 -> id . set Vty.blue RGB 0 0 255 -> bold . set Vty.blue- RGB 128 0 128 -> nullA . set Vty.magenta+ RGB 128 0 128 -> id . set Vty.magenta RGB 255 0 255 -> bold . set Vty.magenta- RGB 0 139 139 -> nullA . set Vty.cyan+ RGB 0 139 139 -> id . set Vty.cyan RGB 0 255 255 -> bold . set Vty.cyan- RGB 165 165 165 -> nullA . set Vty.white+ RGB 165 165 165 -> id . set Vty.white RGB 255 255 255 -> bold . set Vty.white- Default -> nullA . set Vty.def- Reverse -> reverseA . set Vty.def- _ -> nullA . set unknown -- NB+ Default -> id . set Vty.def+ _ -> id . set unknown -- NB attributesToAttr :: Attributes -> (Vty.Attr -> Vty.Attr)-attributesToAttr (Attributes fg bg) =- colorToAttr boldA setFG Vty.black fg .- colorToAttr nullA setBG Vty.white bg+attributesToAttr (Attributes fg bg reverse) =+ (if reverse then setRV else id) .+ colorToAttr setBold setFG Vty.black fg .+ colorToAttr id setBG Vty.white bg ---------------------------------
tests/TestSuite.hs view
@@ -5,7 +5,7 @@ import Data.Traversable import Control.Monad.Identity-import Text.Show.Functions+import Text.Show.Functions () main :: IO () main = Driver.main tests@@ -25,5 +25,4 @@ ("WindowSet prop_traversable" , mytest (prop_traversable :: WindowSet Int -> (Int -> Int) -> Bool)) ] --- instance Show (a -> b) where--- show f = "<func>"+
yi.cabal view
@@ -1,5 +1,5 @@ name: yi-version: 0.5.0.1+version: 0.5.2 category: Development, Editor synopsis: The Haskell-Scriptable Editor description:@@ -11,7 +11,7 @@ maintainer: yi-devel@googlegroups.com homepage: http://haskell.org/haskellwiki/Yi -Cabal-Version: >= 1.4+Cabal-Version: >= 1.6 tested-with: GHC==6.8.3 build-type: Simple data-files:@@ -84,6 +84,7 @@ Yi.Event Yi.File Yi.History+ Yi.IReader Yi.IncrementalParse Yi.Interact Yi.Interpreter@@ -103,7 +104,9 @@ Yi.Lexer.Haskell Yi.Lexer.Latex Yi.Lexer.LiterateHaskell+ Yi.Lexer.GNUMake Yi.Lexer.OCaml+ Yi.Lexer.Ott Yi.Lexer.Perl Yi.Lexer.Python Yi.Lexer.Srmc@@ -113,7 +116,9 @@ Yi.MkTemp Yi.Mode.Compilation Yi.Mode.Haskell+ Yi.Mode.IReader Yi.Mode.Interactive+ Yi.Mode.Latex Yi.Modes Yi.Monad Yi.Prelude@@ -131,8 +136,10 @@ Yi.Syntax.Latex Yi.Syntax.Layout Yi.Syntax.Linear+ Yi.Syntax.OnlineTree Yi.Syntax.Paren Yi.Syntax.Tree+ Yi.Tag Yi.Templates Yi.TextCompletion, Yi.UI.Common@@ -188,6 +195,7 @@ -- Should probably be split out to another package. Data.ByteRope Data.DelayList+ Data.Trie Shim.CabalInfo Shim.Utils Shim.ProjectContent@@ -201,22 +209,16 @@ -- Yi.Keymap.Nano, -- Yi.Keymap.Vi, --- extensions: CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,--- ForeignFunctionInterface, FunctionalDependencies, GADTs,--- GeneralizedNewtypeDeriving, MagicHash, MultiParamTypeClasses,--- ParallelListComp, PatternGuards, PatternSignatures, Rank2Types,--- ScopedTypeVariables TypeSynonymInstances, UndecidableInstances -- executable yi build-tools: alex >= 2.0.1 && < 3 -- haddock >= 2.2, -- it seems harsh to require haddock 2.2 to even configure Yi - build-depends: Cabal >= 1.4 && < 1.5+ build-depends: Cabal >= 1.6 && < 1.7 build-depends: Diff >=0.1 && <0.2- build-depends: array, base, containers, directory, mtl, process, old-locale, old-time, random+ build-depends: array, containers, directory, mtl, process, old-locale, old-time, random+ build-depends: base == 3.* build-depends: binary >=0.4.2 && <0.5 build-depends: bytestring >=0.9.1 && <0.9.2 -- build-depends: derive >=0.1 && <0.2 @@ -224,11 +226,12 @@ -- --> can't use. build-depends: filepath>=1.1 && <1.2 build-depends: fingertree >= 0 && <0.1+ build-depends: ghc-paths ==0.1.* build-depends: parsec >= 3 && <= 3.0.2 build-depends: unix-compat >=0.1 && <0.2 build-depends: pureMD5 >= 0.2.3- build-depends: regex-base ==0.93.1- build-depends: regex-tdfa ==0.94 + build-depends: regex-base ==0.93.*+ build-depends: regex-tdfa >=0.95.2 build-depends: rosezipper >= 0.1 && < 0.2 build-depends: utf8-string >= 0.3.1 @@ -259,16 +262,15 @@ cpp-options: -DFRONTEND_COCOA if flag (ghcAPI)- build-depends: ghc==6.8.3+ build-depends: ghc == 6.8.3 || == 6.10.1 build-depends: haskell98- build-depends: ghc-paths >=0.1.0.5 && < 0.1.2 cpp-options: -DGHC_API if !(flag(vty) || flag (gtk) || flag(cocoa)) buildable: False main-is: Main.hs- + other-modules: Yi Yi.Prelude@@ -299,12 +301,15 @@ Yi.Lexer.Latex Yi.Lexer.Srmc Yi.Lexer.Cabal+ Yi.Lexer.GNUMake Yi.Lexer.OCaml+ Yi.Lexer.Ott Yi.Lexer.Perl Yi.Lexer.Python Yi.Syntax Yi.Syntax.Layout+ Yi.Syntax.OnlineTree Yi.Syntax.Paren Yi.Syntax.Fractal Yi.Syntax.Latex@@ -313,7 +318,7 @@ Yi.Mode.Interactive - Yi.Accessor, Yi.Interpreter,+ Yi.Interpreter, Yi.Buffer.Indent Yi.Buffer.HighLevel, Yi.Buffer.Implementation, Yi.Buffer.Normal, Yi.Buffer.Region, Yi.Completion, Yi.Core,