yi 0.6.3.0 → 0.6.4.0
raw patch · 93 files changed
+3647/−1228 lines, 93 filesdep +concrete-typerepdep +ghcdep +ghc-syb-utilsdep ~cautious-filebinary-added
Dependencies added: concrete-typerep, ghc, ghc-syb-utils, hashable, scion, unordered-containers
Dependency ranges changed: cautious-file
Files
- art/yi+lambda-fat-128.png binary
- art/yi+lambda-fat-16.png binary
- art/yi+lambda-fat-32.png binary
- art/yi+lambda-fat-64.png binary
- art/yi+lambda-fat.pdf binary
- src/library/Data/Rope.hs +21/−20
- src/library/Data/Trie.hs +6/−0
- src/library/Parser/Incremental.hs +0/−1
- src/library/Shim/CabalInfo.hs +2/−2
- src/library/Shim/Hsinfo.hs +0/−1
- src/library/Shim/ProjectContent.hs +28/−15
- src/library/Shim/Utils.hs +1/−1
- src/library/System/CanonicalizePath.hs +66/−0
- src/library/System/FriendlyPath.hs +22/−34
- src/library/Yi/Boot.hs +29/−16
- src/library/Yi/Buffer/Basic.hs +8/−3
- src/library/Yi/Buffer/HighLevel.hs +7/−2
- src/library/Yi/Buffer/Implementation.hs +6/−5
- src/library/Yi/Buffer/Misc.hs +27/−9
- src/library/Yi/Buffer/Normal.hs +10/−3
- src/library/Yi/Buffer/Region.hs +9/−0
- src/library/Yi/Buffer/Undo.hs +0/−2
- src/library/Yi/Command.hs +1/−1
- src/library/Yi/Config.hs +21/−5
- src/library/Yi/Config/Default.hs +18/−16
- src/library/Yi/Config/Simple.hs +357/−0
- src/library/Yi/Config/Simple/Types.hs +35/−0
- src/library/Yi/Core.hs +1/−2
- src/library/Yi/Debug.hs +1/−1
- src/library/Yi/Dired.hs +303/−298
- src/library/Yi/Dynamic.hs +124/−38
- src/library/Yi/Editor.hs +95/−26
- src/library/Yi/Eval.hs +136/−44
- src/library/Yi/Event.hs +1/−1
- src/library/Yi/File.hs +3/−6
- src/library/Yi/History.hs +6/−1
- src/library/Yi/Hoogle.hs +0/−1
- src/library/Yi/Hooks.hs +92/−0
- src/library/Yi/IReader.hs +20/−18
- src/library/Yi/IncrementalParse.hs +2/−1
- src/library/Yi/Keymap.hs +1/−1
- src/library/Yi/Keymap/Emacs.hs +14/−3
- src/library/Yi/Keymap/Emacs/KillRing.hs +0/−1
- src/library/Yi/Keymap/Emacs/Utils.hs +8/−6
- src/library/Yi/Keymap/Keys.hs +8/−3
- src/library/Yi/Keymap/Vim.hs +35/−14
- src/library/Yi/KillRing.hs +0/−2
- src/library/Yi/Layout.hs +365/−0
- src/library/Yi/Lexer/Alex.hs +1/−0
- src/library/Yi/Lexer/GitCommit.x +100/−0
- src/library/Yi/Lexer/Java.x +188/−0
- src/library/Yi/Main.hs +41/−23
- src/library/Yi/MiniBuffer.hs +36/−4
- src/library/Yi/Misc.hs +2/−4
- src/library/Yi/Mode/Abella.hs +1/−0
- src/library/Yi/Mode/Buffers.hs +0/−2
- src/library/Yi/Mode/Compilation.hs +2/−3
- src/library/Yi/Mode/Haskell.hs +36/−34
- src/library/Yi/Mode/Haskell/Dollarify.hs +2/−2
- src/library/Yi/Mode/JavaScript.hs +7/−6
- src/library/Yi/Modes.hs +19/−3
- src/library/Yi/Monad.hs +0/−1
- src/library/Yi/Prelude.hs +53/−6
- src/library/Yi/Process.hs +5/−4
- src/library/Yi/Rectangle.hs +0/−2
- src/library/Yi/Regex.hs +1/−0
- src/library/Yi/Region.hs +5/−1
- src/library/Yi/Scion.hs +3/−3
- src/library/Yi/Search.hs +4/−2
- src/library/Yi/Snippets.hs +14/−6
- src/library/Yi/Style.hs +1/−1
- src/library/Yi/Syntax.hs +2/−2
- src/library/Yi/Syntax/Driver.hs +5/−4
- src/library/Yi/Syntax/Haskell.hs +11/−12
- src/library/Yi/Syntax/Latex.hs +2/−1
- src/library/Yi/Syntax/Layout.hs +3/−3
- src/library/Yi/Syntax/OnlineTree.hs +4/−6
- src/library/Yi/Syntax/Paren.hs +5/−5
- src/library/Yi/Syntax/Strokes/Haskell.hs +2/−1
- src/library/Yi/Syntax/Tree.hs +6/−4
- src/library/Yi/Tab.hs +108/−0
- src/library/Yi/Tag.hs +14/−3
- src/library/Yi/TextCompletion.hs +3/−1
- src/library/Yi/UI/Common.hs +41/−0
- src/library/Yi/UI/Pango.hs +525/−435
- src/library/Yi/UI/Pango/Control.hs +59/−13
- src/library/Yi/UI/Pango/Layouts.hs +392/−0
- src/library/Yi/UI/TabBar.hs +2/−1
- src/library/Yi/UI/Vte.hs +7/−3
- src/library/Yi/UI/Vty.hs +1/−0
- src/library/Yi/Window.hs +6/−10
- src/tests/Driver.hs +1/−4
- yi.cabal +38/−10
+ art/yi+lambda-fat-128.png view
binary file changed (absent → 22701 bytes)
+ art/yi+lambda-fat-16.png view
binary file changed (absent → 1483 bytes)
+ art/yi+lambda-fat-32.png view
binary file changed (absent → 3857 bytes)
+ art/yi+lambda-fat-64.png view
binary file changed (absent → 10133 bytes)
+ art/yi+lambda-fat.pdf view
binary file changed (absent → 6346 bytes)
src/library/Data/Rope.hs view
@@ -38,7 +38,7 @@ import qualified Data.List as L import qualified Data.ByteString.UTF8 as B-import qualified Data.ByteString as B (append, concat, elemIndices)+import qualified Data.ByteString as B (append, concat) import qualified Data.ByteString as Byte import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB (toChunks, fromChunks, null, readFile)@@ -50,14 +50,8 @@ import Data.Binary import Data.Char (ord) import Data.Monoid-import Data.Foldable (toList)-import Data.Int -#ifdef CAUTIOUS_WRITES import System.IO.Cautious (writeFileL)-#else-import qualified Data.ByteString.Lazy as LB (writeFile)-#endif defaultChunkSize :: Int defaultChunkSize = 128 -- in chars! (chunkSize requires this to be <= 256)@@ -66,10 +60,10 @@ -- means that the length of chunks often have to be recomputed. mkChunk :: ByteString -> Chunk mkChunk s = Chunk (fromIntegral $ B.length s) s-data Chunk = Chunk { chunkSize :: !Word8, fromChunk :: !ByteString }+data Chunk = Chunk { chunkSize :: {-# UNPACK #-} !Word8, fromChunk :: {-# UNPACK #-} !ByteString } deriving (Eq, Show) -data Size = Indices {charIndex :: !Int, lineIndex :: Int} -- lineIndex is lazy because we do not often want the line count.+data Size = Indices {charIndex :: {-# UNPACK #-} !Int, lineIndex :: {-# UNPACK #-} !Int} -- lineIndex is lazy because we do not often want the line count. However, we need this to avoid stack overflows on large files! deriving Show instance Monoid Size where@@ -95,6 +89,13 @@ measure (Chunk l s) = Indices (fromIntegral l) -- note that this is the length in characters, not bytes. (Byte.count newline s) +-- | The 'Foldable' instance of 'FingerTree' only defines 'foldMap', so the 'foldr' needed for 'toList' is inefficient,+-- and can cause stack overflows. So, we roll our own (somewhat inefficient) version of 'toList' to avoid this.+toList :: Measured v a => FingerTree v a -> [a]+toList t = case viewl t of+ c :< cs -> c : toList cs+ EmptyL -> []+ toLazyByteString :: Rope -> LB.ByteString toLazyByteString = LB.fromChunks . fmap fromChunk . toList . fromRope @@ -108,17 +109,21 @@ toString = LB.toString . toLazyByteString fromLazyByteString :: LB.ByteString -> Rope-fromLazyByteString = Rope . toTree+fromLazyByteString = Rope . toTree T.empty where- toTree b | LB.null b = T.empty- toTree b = let (h,t) = LB.splitAt (fromIntegral defaultChunkSize) b in (mkChunk $ B.concat $ LB.toChunks $ h) <| toTree t+ toTree acc b | LB.null b = acc+ | otherwise = let (h,t) = LB.splitAt (fromIntegral defaultChunkSize) b+ chunk = mkChunk $ B.concat $ LB.toChunks $ h+ in acc `seq` chunk `seq` toTree (acc |> chunk) t fromString :: String -> Rope-fromString = Rope . toTree+fromString = Rope . toTree T.empty where- toTree [] = T.empty- toTree b = let (h,t) = L.splitAt defaultChunkSize b in (mkChunk $ B.fromString h) <| toTree t+ toTree acc [] = acc+ toTree acc b = let (h,t) = L.splitAt defaultChunkSize b + chunk = mkChunk $ B.fromString h+ in acc `seq` chunk `seq` toTree (acc |> chunk) t null :: Rope -> Bool null (Rope a) = T.null a@@ -198,11 +203,7 @@ writeFile :: FilePath -> Rope -> IO ()-#ifdef CAUTIOUS_WRITES-writeFile f r = writeFileL f $ toLazyByteString r-#else-writeFile f r = LB.writeFile f $ toLazyByteString r-#endif+writeFile f = writeFileL f . toLazyByteString readFile :: FilePath -> IO Rope readFile f = fromLazyByteString `fmap` LB.readFile f
src/library/Data/Trie.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+ module Data.Trie where -- Trie module. Partly taken from http://www.haskell.org/haskellwiki/Haskell_Quiz/Word_Search/Solution_Sjanssen +import Data.Binary+import Data.DeriveTH import qualified Data.Map as Map import Control.Monad @@ -60,3 +64,5 @@ certainSuffix :: String -> Trie -> String certainSuffix prefix fulltrie = lookupPrefix prefix fulltrie >>= forcedNext++$(derive makeBinary ''Trie)
src/library/Parser/Incremental.hs view
@@ -16,7 +16,6 @@ ) where import Control.Applicative-import Data.List hiding (map, minimumBy) import Data.Tree -- Local versions of our Control.Arrow friends (also make sure they are lazy enough)
src/library/Shim/CabalInfo.hs view
@@ -5,14 +5,14 @@ import qualified Control.OldException as CE import System.FilePath import Control.Monad.State-import Data.Maybe import Control.Applicative import Distribution.ModuleName import Distribution.PackageDescription import qualified Distribution.PackageDescription as Library (Library(..)) import qualified Distribution.PackageDescription as BuildInfo (BuildInfo(..))-import System.Directory+import System.Directory hiding (canonicalizePath)+import System.CanonicalizePath guessCabalFile :: String -> IO (Maybe FilePath) guessCabalFile sourcefile = do
src/library/Shim/Hsinfo.hs view
@@ -19,7 +19,6 @@ import Data.List ( isPrefixOf, find, nubBy, sort, (\\) ) import Data.Maybe import System.Directory-import System.Directory (canonicalizePath) import System.FilePath ( takeDirectory, (</>), (<.>), dropFileName, takeExtension, equalFilePath ) import System.Time ( getClockTime, ClockTime ) import qualified Data.ByteString.Lazy.Char8 as BC
src/library/Shim/ProjectContent.hs view
@@ -5,6 +5,8 @@ -- already configured Cabal package. -- +-- TODO: much of this module was commented out to avoid 'defined but not used' warnings. The commented functions should either be exported or removed.+ module Shim.ProjectContent ( {- loadProject , -} itemName@@ -14,23 +16,21 @@ , 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+-}+import Distribution.ModuleName+import Distribution.Version+import Distribution.Package+import Distribution.Text data ProjectItem = ProjectItem@@ -112,6 +112,7 @@ return (tree tloc5, tree tloc6) -} +{- getTop :: Tree a -> TreeLoc a getTop = fromTree @@ -124,20 +125,28 @@ modify' :: (a -> Maybe a) -> State a () modify' f = modify (\x -> maybe (error "impossible movement!") id (f x)) -+addLibraryTree :: FilePath+ -> (Set.Set ProjectItem, TreeLoc ProjectItem)+ -> Library+ -> IO (Set.Set ProjectItem, TreeLoc ProjectItem) 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,_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 :: FilePath+ -> (Set.Set ProjectItem, TreeLoc ProjectItem)+ -> Executable+ -> IO (Set.Set ProjectItem, TreeLoc ProjectItem) 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)+ (_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 :: [PackageIdentifier] -> State (TreeLoc ProjectItem) () addDependenciesTree deps = do insertDown (DependenciesItem "Dependencies") mapM_ addDependency deps@@ -156,8 +165,8 @@ (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))+ (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@@ -169,7 +178,7 @@ addFilePath' :: (String -> ProjectItem) -> [String] -> State (TreeLoc ProjectItem) () -> State (TreeLoc ProjectItem) ()-addFilePath' mkItem [] cont = cont+addFilePath' _ [] cont = cont addFilePath' mkItem (c:cs) cont | c == "." = addFilePath' mkItem cs cont | otherwise = do let item | null cs = mkItem c@@ -192,8 +201,10 @@ then modify $ insertRight $ simpleNode item else modify' right >> insertItem c item +simpleNode :: a -> Tree a simpleNode item = Node item [] +splitPath' :: FilePath -> [String] splitPath' fpath = [removeSlash c | c <- splitPath fpath] where removeSlash c@@ -201,6 +212,7 @@ | isPathSeparator (last c) = init c | otherwise = c +checkAndAddFile :: FilePath -> FilePath -> FileKind -> TreeLoc ProjectItem -> IO (TreeLoc ProjectItem) checkAndAddFile projPath fpath kind tloc = do let fullPath = projPath </> fpath exists <- doesFileExist fullPath@@ -215,7 +227,7 @@ findModules :: FilePath -- ^source directory location -> [ModuleName] -- ^module names -> IO ([(ModuleName,FilePath)],[ModuleName]) -- ^found modules and unknown modules-findModules location [] = return ([],[])+findModules _ [] = return ([],[]) findModules location (mod:mods) = do mb_paths <- findFileWithExtension' (map fst knownSuffixHandlers ++ ["hs", "lhs"]) [location] (toFilePath mod) (locs,unks) <- findModules location mods@@ -230,3 +242,4 @@ if exists then return (Just x) else findFirst xs+-}
src/library/Shim/Utils.hs view
@@ -48,7 +48,7 @@ processGetContents cmd args = do (_,out,_,pid) <- runInteractiveProcess cmd args Nothing Nothing s <- hGetContents out- waitForProcess pid+ _ <- waitForProcess pid return s recurseDir :: (Monad m) => (FilePath -> m (Maybe a)) -> FilePath -> m (Maybe a)
+ src/library/System/CanonicalizePath.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}++-- | System.Directory.canonicalizePath replacement+module System.CanonicalizePath+ ( canonicalizePath+ , normalisePath+ ) where++#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#endif++import Control.Applicative+import Control.Monad+import Data.List.Split (splitOn)+import System.FilePath ((</>), isAbsolute, takeDirectory, pathSeparator)+import System.Directory (getCurrentDirectory)+import System.Posix.Files (readSymbolicLink)+++-- | Removes `/./` `//` and `/../` sequences from path,+-- doesn't follow symlinks+normalisePath :: FilePath -> IO FilePath+normalisePath path = do + absPath <- makeAbsolute path+ return $ foldl combinePath "/" $ splitPath absPath++-- | Returns absolute name of the file, which doesn't contain+-- any `/./`, `/../`, `//` sequences or symlinks+canonicalizePath :: FilePath -> IO FilePath+canonicalizePath path = do+#if !defined(mingw32_HOST_OS)+ absPath <- makeAbsolute path+ foldM (\x y -> expandSym $ combinePath x y) "/" $ splitPath absPath+#else+ Win32.getFullPathName . normalise+#endif++-- | Dereferences symbolic links until regular+-- file/directory/something_else appears +expandSym :: FilePath -> IO FilePath+expandSym fpath = do+ -- System.Posix.Files.getFileStatus dereferences symlink before+ -- checking its status, so it's useless here+ deref <- catch (Just <$> readSymbolicLink fpath) (\_ -> return Nothing)+ case deref of+ Just slink -> if isAbsolute slink then expandSym slink+ else expandSym $ foldl combinePath (takeDirectory fpath) $ splitPath slink+ Nothing -> return fpath+ ++-- | Make a path absolute.+makeAbsolute :: FilePath -> IO FilePath+makeAbsolute f+ | not (null f) && head f `elem` ['~', pathSeparator] = return f+ | otherwise = fmap (</> f) getCurrentDirectory++-- | Combines two paths, moves up one level on ..+combinePath :: FilePath -> String -> FilePath+combinePath x "." = x+combinePath x ".." = takeDirectory x+combinePath x y = x </> y++-- | Splits path into parts by path separator+splitPath :: FilePath -> [String]+splitPath = filter (not . null) . splitOn [pathSeparator]
src/library/System/FriendlyPath.hs view
@@ -1,39 +1,23 @@-module System.FriendlyPath where-import System.FilePath-import System.Directory-import Data.List----- | A version of canonicalizePath that works.---- Note that we cannot use canonicalizePath because if used on a non existing directory--- then the file part will be dropped (arguably this is a bug in canonicalizePath)--- eg. @x/y@ can become @x@, and we do not want that.-canonicalizePathFix :: FilePath -> IO FilePath-canonicalizePathFix f = do- de <- doesDirectoryExist (takeDirectory f)- if de then canonicalizePath f else makeAbsolute f----- The documentation for 'System.FilePath.makeRelative' is wrong. It says+module System.FriendlyPath+ ( userToCanonPath+ , expandTilda+ , isAbsolute'+ ) where --- There is no corresponding makeAbsolute function, instead use--- System.Directory.canonicalizePath which has the same effect.+import Control.Applicative+import System.FilePath+import System.Posix.User (getUserEntryForName, homeDirectory)+import System.CanonicalizePath+import System.Directory hiding (canonicalizePath) -- canonicalizePath follows symlinks, and does not work if the directory does not exist. --- | Make a path absolute.-makeAbsolute :: FilePath -> IO FilePath-makeAbsolute f- | isAbsolute' f = return f- | otherwise = fmap (</> f) getCurrentDirectory -- -- | Canonicalize a user-friendly path userToCanonPath :: FilePath -> IO String-userToCanonPath f = canonicalizePathFix =<< expandTilda f-+userToCanonPath f = canonicalizePath =<< expandTilda f +{-+TODO: export or remove -- | Make a path more user-friendly by replacing the home directory with tilda. recoverTilda :: FilePath -> IO String recoverTilda path = do@@ -44,14 +28,18 @@ -- | Turn a path into its canonicalized, user-friendly version. canonicalizePath' :: FilePath -> IO String-canonicalizePath' f = recoverTilda =<< canonicalizePathFix f+canonicalizePath' f = recoverTilda =<< canonicalizePath f+-} -- | Turn a user-friendly path into a computer-friendly path by expanding the leading tilda. expandTilda :: String -> IO FilePath-expandTilda "~" = getHomeDirectory-expandTilda s0 = do- home <- getHomeDirectory- return $ if (['~',pathSeparator] `isPrefixOf` s0) then home </> drop 2 s0 else s0+expandTilda ('~':path)+ | (null path) || (head path == pathSeparator) = (++ path) <$> getHomeDirectory+ -- Home directory of another user, e.g. ~root/+ | otherwise = let username = takeWhile (/= pathSeparator) path+ dirname = drop (length username) path+ in (normalise . (++ dirname) . homeDirectory) <$> getUserEntryForName username+expandTilda path = return path -- | Is a user-friendly path absolute? isAbsolute' :: String -> Bool
src/library/Yi/Boot.hs view
@@ -2,37 +2,50 @@ module Yi.Boot (yi, yiDriver, reload) where import qualified Config.Dyre as Dyre+import qualified Config.Dyre.Options as Dyre import Config.Dyre.Relaunch import Control.Monad.State import qualified Data.Rope as R import System.Directory+import System.Environment+import System.Exit import Yi.Config import Yi.Editor import Yi.Keymap-import qualified Yi.Main+import Yi.Main import qualified Yi.UI.Common as UI -realMain :: Config -> IO ()-realMain config = do+realMain :: (Config, ConsoleConfig) -> IO ()+realMain configs = do editor <- restoreBinaryState Nothing- Yi.Main.main config editor+ main configs editor -showErrorsInConf :: Config -> String -> Config-showErrorsInConf conf errs- = conf { initialActions = (makeAction $ newBufferE (Left "*errors*") (R.fromString errs)) : initialActions conf }+showErrorsInConf :: (Config, ConsoleConfig) -> String -> (Config, ConsoleConfig)+showErrorsInConf (conf, confcon) errs+ = (conf { initialActions = (makeAction $ splitE >> newBufferE (Left "*errors*") (R.fromString errs)) : initialActions conf }+ , confcon) yi, yiDriver :: Config -> IO ()+yi = yiDriver -(yiDriver, yi) = (Dyre.wrapMain yiParams, Dyre.wrapMain yiParams)- where yiParams = Dyre.defaultParams- { Dyre.projectName = "yi"- , Dyre.realMain = realMain- , Dyre.showError = showErrorsInConf- , Dyre.configDir = Just . getAppUserDataDirectory $ "yi"- , Dyre.hidePackages = ["mtl"]- , Dyre.ghcOpts = ["-threaded", "-O2"]- }+yiDriver cfg = do+ args <- Dyre.withDyreOptions Dyre.defaultParams getArgs + -- we do the arg processing before dyre, so we can extract '--ghc-option=' and '--help' and so on.+ case do_args cfg args of+ Left (Err err code) ->+ do putStrLn err+ exitWith code+ Right (finalCfg, cfgcon) -> + let yiParams = Dyre.defaultParams+ { Dyre.projectName = "yi"+ , Dyre.realMain = realMain+ , Dyre.showError = showErrorsInConf+ , Dyre.configDir = Just . getAppUserDataDirectory $ "yi"+ , Dyre.hidePackages = ["mtl"]+ , Dyre.ghcOpts = ["-threaded", "-O2"] ++ ghcOptions cfgcon+ }+ in Dyre.wrapMain yiParams (finalCfg, cfgcon) reload :: YiM () reload = do
src/library/Yi/Buffer/Basic.hs view
@@ -6,15 +6,13 @@ import Data.Binary import Yi.Prelude import qualified Data.Rope as R-import Data.Typeable import Data.DeriveTH-import Data.Derive.Binary import Data.Ix -- | Direction of movement inside a buffer data Direction = Backward | Forward- deriving (Eq,Ord,Typeable,Show)+ deriving (Eq,Ord,Typeable,Show,Bounded,Enum) $(derive makeBinary ''Direction) @@ -67,3 +65,10 @@ fromString :: String -> Rope fromString = R.fromString++-- | Window references+newtype WindowRef = WindowRef { unWindowRef :: Int }+ deriving(Eq, Ord, Enum, Show, Typeable, Binary)++instance Initializable WindowRef where initial = WindowRef (-1)+
src/library/Yi/Buffer/HighLevel.hs view
@@ -621,8 +621,13 @@ sortLines = modifyExtendedSelectionB Line (onLines sort) -- | Helper function: revert the buffer contents to its on-disk version-revertB :: String -> UTCTime -> BufferM ()+revertB :: Rope -> UTCTime -> BufferM () revertB s now = do r <- regionOfB Document- replaceRegionClever r s+ if R.length s <= smallBufferSize -- for large buffers, we must avoid building strings, because we'll end up using huge amounts of memory+ then replaceRegionClever r (R.toString s)+ else replaceRegionB' r s markSavedB now++smallBufferSize :: Int+smallBufferSize = 1000000
src/library/Yi/Buffer/Implementation.hs view
@@ -77,9 +77,10 @@ deriving (Ord, Eq) data Overlay = Overlay { overlayLayer :: OvlLayer,- overlayBegin :: MarkValue,- overlayEnd :: MarkValue,- overlayStyle :: StyleName+ -- underscores to avoid 'defined but not used'. Remove if desired+ _overlayBegin :: MarkValue,+ _overlayEnd :: MarkValue,+ _overlayStyle :: StyleName } instance Eq Overlay where Overlay a b c _ == Overlay a' b' c' _ = a == a' && b == b' && c == c'@@ -377,8 +378,8 @@ in (fb {marks = mks', markNames = nms'}, newMark) -getAst :: Int -> BufferImpl syntax -> syntax+getAst :: WindowRef -> BufferImpl syntax -> syntax getAst w FBufferData {hlCache = HLState (SynHL {hlGetTree = gt}) cache} = gt cache w -focusAst :: M.Map Int Region -> BufferImpl syntax -> BufferImpl syntax+focusAst :: M.Map WindowRef Region -> BufferImpl syntax -> BufferImpl syntax focusAst r b@FBufferData {hlCache = HLState s@(SynHL {hlFocus = foc}) cache} = b {hlCache = HLState s (foc r cache)}
src/library/Yi/Buffer/Misc.hs view
@@ -42,6 +42,7 @@ , leftN , rightN , insertN+ , insertNAt' , insertNAt , insertB , deleteN@@ -94,6 +95,20 @@ , clearSyntax , focusSyntax , Mode (..)+ , modeNameA+ , modeAppliesA+ , modeHLA+ , modePrettifyA+ , modeKeymapA+ , modeIndentA+ , modeAdjustBlockA+ , modeFollowA+ , modeIndentSettingsA+ , modeToggleCommentSelectionA+ , modeGetStrokesA+ , modeGetAnnotationsA+ , modePrintTreeA+ , modeOnLoadA , AnyMode (..) , IndentBehaviour (..) , IndentSettings (..)@@ -216,14 +231,13 @@ $(nameDeriveAccessors ''Attributes (\n -> Just (n ++ "AA"))) --- unfortunately the dynamic stuff can't be read. instance Binary Attributes where- put (Attributes n b u _bd pc pu selectionStyle_ _proc wm law lst ro ins _pfw) = do- put n >> put b >> put u+ put (Attributes n b u bd pc pu selectionStyle_ _proc wm law lst ro ins _pfw) = do+ put n >> put b >> put u >> put bd put pc >> put pu >> put selectionStyle_ >> put wm put law >> put lst >> put ro >> put ins get = Attributes <$> get <*> get <*> get <*> - pure emptyDV <*> get <*> get <*> get <*> pure I.End <*> get <*> get <*> get <*> get <*> get <*> pure (const False)+ get <*> get <*> get <*> get <*> pure I.End <*> get <*> get <*> get <*> get <*> get <*> pure (const False) instance Binary UTCTime where put (UTCTime x y) = put (fromEnum x) >> put (fromEnum y)@@ -343,7 +357,7 @@ keymapProcessA :: Accessor FBuffer KeymapProcess keymapProcessA = processAA . attrsA -winMarksA :: Accessor FBuffer (M.Map Int WinMarks)+winMarksA :: Accessor FBuffer (M.Map WindowRef WinMarks) winMarksA = winMarksAA . attrsA {- | Currently duplicates some of Vim's indent settings. Allowing a buffer to@@ -499,7 +513,7 @@ ms <- getMarks w when (isNothing ms) $ do -- this window has no marks for this buffer yet; have to create them.- newMarkValues <- if wkey (b ^. lastActiveWindowA) == dummyWindowKey+ newMarkValues <- if wkey (b ^. lastActiveWindowA) == initial then return -- no previous window, create some marks from scratch. MarkSet { insMark = MarkValue 0 Forward,@@ -601,7 +615,7 @@ , bkey__ = unique , undos = emptyU , preferCol = Nothing- , bufferDynamic = emptyDV + , bufferDynamic = initial , pendingUpdates = [] , selectionStyle = SelectionStyle False False , process = I.End@@ -698,10 +712,12 @@ newlineB = insertB '\n' ------------------------------------------------------------------------+insertNAt' :: Rope -> Point -> BufferM ()+insertNAt' rope pnt = applyUpdate (Insert pnt Forward $ rope) -- | Insert the list at specified point, extending size of buffer insertNAt :: String -> Point -> BufferM ()-insertNAt cs pnt = applyUpdate (Insert pnt Forward $ R.fromString cs)+insertNAt cs pnt = insertNAt' (R.fromString cs) pnt -- | Insert the list at current point, extending size of buffer insertN :: String -> BufferM ()@@ -974,7 +990,7 @@ -- -- > putA bufferDynamicValueA updatedvalue -- > value <- getA bufferDynamicValueA-bufferDynamicValueA :: Initializable a => Accessor FBuffer a+bufferDynamicValueA :: YiVariable a => Accessor FBuffer a bufferDynamicValueA = dynamicValueA . bufferDynamicA -- | perform a @BufferM a@, and return to the current point. (by using a mark)@@ -1004,3 +1020,5 @@ askWindow :: (Window -> a) -> BufferM a askWindow = asks++$(nameDeriveAccessors ''Mode (\n -> Just (n ++ "A")))
src/library/Yi/Buffer/Normal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} -- -- Copyright (C) 2008 JP Bernardy --@@ -43,16 +43,19 @@ , regionStyleA ) where +import Prelude(length, subtract)+import Yi.Prelude import Yi.Buffer.Basic import Yi.Buffer.Misc import Yi.Buffer.Region import Yi.Dynamic import Data.Char import Data.List (sort)-import Control.Applicative import Control.Monad-import Data.Accessor (Accessor) +import Data.Binary+import Data.DeriveTH+ -- | Designate a given "unit" of text. data TextUnit = Character -- ^ a single character | Line -- ^ a line of text (between newlines)@@ -404,9 +407,13 @@ | Block deriving (Eq, Typeable, Show) +$(derive makeBinary ''RegionStyle)+ -- TODO: put in the buffer state proper. instance Initializable RegionStyle where initial = Inclusive++instance YiVariable RegionStyle regionStyleA :: Accessor FBuffer RegionStyle regionStyleA = bufferDynamicValueA
src/library/Yi/Buffer/Region.hs view
@@ -9,6 +9,7 @@ , swapRegionsB , deleteRegionB , replaceRegionB+ , replaceRegionB' , replaceRegionClever , readRegionB , mapRegionB@@ -44,6 +45,14 @@ replaceRegionB r s = do deleteRegionB r insertNAt s (regionStart r)++-- | Replace a region with a given rope.+replaceRegionB' :: Region -> Rope -> BufferM ()+replaceRegionB' r s = do+ deleteRegionB r+ insertNAt' s (regionStart r)++-- TODO: reimplement 'getGroupedDiff' for Ropes, so we can use 'replaceRegionClever' on large regions. -- | As 'replaceRegionB', but do a minimal edition instead of deleting the whole -- region and inserting it back.
src/library/Yi/Buffer/Undo.hs view
@@ -57,10 +57,8 @@ , Change(AtomicChange, InteractivePoint) ) where -import Control.Monad (ap) import Data.Binary import Data.DeriveTH-import Data.Derive.Binary import Yi.Buffer.Implementation data Change = SavedFilePoint
src/library/Yi/Command.hs view
@@ -13,7 +13,6 @@ {- Local (yi) module imports -} import Prelude ()-import Yi.Prelude (discard) import Yi.Core import Yi.MiniBuffer import qualified Yi.Mode.Compilation as Compilation@@ -55,6 +54,7 @@ newtype CabalBuffer = CabalBuffer {cabalBuffer :: Maybe BufferRef} deriving (Initializable, Typeable, Binary) +instance YiVariable CabalBuffer ---------------------------- -- | cabal-configure
src/library/Yi/Config.hs view
@@ -1,13 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+ module Yi.Config where -import qualified Data.Map as M import Data.Prototype+import Data.Accessor.Template import Yi.Buffer+import Yi.Layout import Yi.Config.Misc import {-# source #-} Yi.Keymap import {-# source #-} Yi.Editor-import Data.Dynamic+import Yi.Dynamic(ConfigVariables) import Yi.Event import Yi.Style import Yi.Style.Library@@ -20,16 +23,24 @@ configFontSize :: Maybe Int, -- ^ Font size, for the UI that support it. configScrollStyle ::Maybe ScrollStyle, -- ^ Style of scroll+ configScrollWheelAmount :: Int, -- ^ Amount to move the buffer when using the scroll wheel configLeftSideScrollBar :: Bool, -- ^ Should the scrollbar be shown on the left side? configAutoHideScrollBar :: Bool, -- ^ Hide scrollbar automatically if text fits on one page. configAutoHideTabBar :: Bool, -- ^ Hide the tabbar automatically if only one tab is present configLineWrap :: Bool, -- ^ Wrap lines at the edge of the window if too long to display.+ configCursorStyle :: CursorStyle, configWindowFill :: Char, -- ^ The char with which to fill empty window space. Usually '~' for vi-like -- editors, ' ' for everything else. configTheme :: Theme -- ^ UI colours } +-- | When should we use a \"fat\" cursor (i.e. 2 pixels wide, rather than 1)? Fat cursors have only been implemented for the Pango frontend.+data CursorStyle = AlwaysFat+ | NeverFat+ | FatWhenFocused+ | FatWhenFocusedAndInserting+ configStyle :: UIConfig -> UIStyle configStyle = extractValue . configTheme @@ -48,8 +59,6 @@ configInputPreprocess :: I.P Event Event, modeTable :: [AnyMode], -- ^ List modes by order of preference.- publishedActions :: M.Map String [Data.Dynamic.Dynamic],- -- ^ Actions available in the "interpreter" (akin to M-x in emacs) debugMode :: Bool, -- ^ Produce a .yi.dbg file with a lot of debug information. configRegionStyle :: RegionStyle,@@ -57,7 +66,11 @@ configKillringAccumulate :: Bool, -- ^ Set to 'True' for an emacs-like behaviour, where -- all deleted text is accumulated in a killring.- bufferUpdateHandler :: [([Update] -> BufferM ())]+ bufferUpdateHandler :: [([Update] -> BufferM ())],+ layoutManagers :: [AnyLayoutManager],+ -- ^ List of layout managers for 'cycleLayoutManagersNext'+ configVars :: ConfigVariables+ -- ^ Custom configuration, containing the 'YiConfigVariable's. Configure with 'configVariableA'. } configFundamentalMode :: Config -> AnyMode@@ -67,3 +80,6 @@ configTopLevelKeymap = extractTopKeymap . defaultKm type UIBoot = Config -> (Event -> IO ()) -> ([Action] -> IO ()) -> Editor -> IO UI++$(nameDeriveAccessors ''Config (\n -> Just (n ++ "A")))+$(nameDeriveAccessors ''UIConfig (\n -> Just (n ++ "A")))
src/library/Yi/Config/Default.hs view
@@ -6,7 +6,6 @@ toVimStyleConfig, toEmacsStyleConfig, toCuaStyleConfig) where import Control.Monad (forever)-import Data.Dynamic import Data.Either (rights) import Paths_yi import Prelude ()@@ -18,9 +17,11 @@ import Yi.Config import Yi.Config.Misc import Yi.Core+import Yi.Eval(publishedActions) import Yi.File import Yi.IReader (saveAsNewArticle) import Yi.Mode.IReader (ireaderMode, ireadMode)+import Yi.Layout import Yi.Modes #ifdef SCION import Yi.Scion@@ -28,6 +29,7 @@ import Yi.Search import Yi.Style.Library import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM import qualified Yi.Keymap.Cua as Cua import qualified Yi.Keymap.Emacs as Emacs import qualified Yi.Keymap.Vim as Vim@@ -76,16 +78,10 @@ -- ... so we can hope getting rid of this someday. -- Failing to conform to this rule exposes the code to instant deletion. -defaultPublishedActions :: M.Map String [Data.Dynamic.Dynamic]-defaultPublishedActions = M.fromList $ - [ ("Backward" , box Backward)- , ("Character" , box Character)- , ("Document" , box Document)- , ("Forward" , box Forward)- , ("Line" , box Line)- , ("unitWord" , box unitWord)- , ("Point" , box Point)- , ("atBoundaryB" , box atBoundaryB)+defaultPublishedActions :: HM.HashMap String Action+defaultPublishedActions = HM.fromList $ + [ + ("atBoundaryB" , box atBoundaryB) , ("cabalBuildE" , box cabalBuildE) , ("cabalConfigureE" , box cabalConfigureE) , ("closeBufferE" , box closeBufferE)@@ -99,7 +95,7 @@ , ("leftB" , box leftB) , ("linePrefixSelectionB" , box linePrefixSelectionB) , ("lineStreamB" , box lineStreamB)- , ("mkRegion" , box mkRegion)+-- , ("mkRegion" , box mkRegion) -- can't make 'instance Promptable Region' , ("makeBuild" , box makeBuild) , ("moveB" , box moveB) , ("numberOfB" , box numberOfB)@@ -116,8 +112,6 @@ , ("setAnyMode" , box setAnyMode) , ("sortLines" , box sortLines) , ("unLineCommentSelectionB", box unLineCommentSelectionB)- , ("unitParagraph" , box unitParagraph)- , ("unitViWord" , box unitViWord) , ("writeB" , box writeB) , ("ghciGet" , box Haskell.ghciGet) , ("abella" , box Abella.abella)@@ -126,18 +120,23 @@ #endif ] - where box x = [Data.Dynamic.toDyn x]+ where + box :: (Show x, YiAction a x) => a -> Action+ box = makeAction defaultConfig :: Config defaultConfig = + publishedActions ^= defaultPublishedActions $ Config { startFrontEnd = case availableFrontends of [] -> error "panic: no frontend compiled in! (configure with -fvty or another frontend.)" ((_,f):_) -> f , configUI = UIConfig { configFontSize = Nothing , configFontName = Nothing+ , configScrollWheelAmount = 4 , configScrollStyle = Nothing+ , configCursorStyle = FatWhenFocusedAndInserting , configLineWrap = True , configLeftSideScrollBar = True , configAutoHideScrollBar = False@@ -149,7 +148,6 @@ , defaultKm = modelessKeymapSet nilKeymap , startActions = [] , initialActions = []- , publishedActions = defaultPublishedActions , modeTable = [AnyMode Haskell.cleverMode, AnyMode Haskell.preciseMode, AnyMode Latex.latexMode3,@@ -167,8 +165,10 @@ AnyMode perlMode, AnyMode (JS.hooks JS.javaScriptMode), AnyMode pythonMode,+ AnyMode javaMode, AnyMode ireaderMode, AnyMode svnCommitMode,+ AnyMode gitCommitMode, AnyMode whitespaceMode, AnyMode fundamentalMode] , debugMode = False@@ -176,6 +176,8 @@ , configRegionStyle = Exclusive , configInputPreprocess = I.idAutomaton , bufferUpdateHandler = []+ , layoutManagers = [hPairNStack 1, vPairNStack 1, tall, wide]+ , configVars = initial } defaultEmacsConfig, defaultVimConfig, defaultCuaConfig :: Config
+ src/library/Yi/Config/Simple.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE Rank2Types, CPP, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- for good documentation, we want control over our export list, which occasionally gives us duplicate exports++{- | A simplified configuration interface for Yi. -}+module Yi.Config.Simple (+ -- $overview+ -- * The main interface+ ConfigM,+ configMain,+ Field,+ (%=),+ get,+ modify,+ -- * Frontend+ setFrontendPreferences,+ setFrontend,+ -- * Modes, commands, and keybindings+ globalBindKeys,+ modeBindKeys,+ modeBindKeysByName,+ addMode,+ modifyMode,+ modifyModeByName,+ -- * Evaluation of commands+ evaluator,+ ghciEvaluator,+ publishedActionsEvaluator,+ publishAction,+ publishedActions,+ -- * Appearance+ fontName,+ fontSize,+ scrollWheelAmount,+ scrollStyle,+ ScrollStyle(..),+ cursorStyle,+ CursorStyle(..),+ Side(..),+ scrollBarSide,+ autoHideScrollBar,+ autoHideTabBar,+ lineWrap,+ windowFill,+ theme,+ -- ** Layout+ layoutManagers,+ -- * Debugging+ debug,+ -- * Startup hooks+ runOnStartup,+ runAfterStartup,+ -- * Advanced+ -- $advanced+ startActions,+ initialActions,+ defaultKm,+ inputPreprocess,+ modes,+ regionStyle,+ killringAccumulate,+ bufferUpdateHandler,+ -- * Module exports+ -- we can't just export 'module Yi', because then we would get clashes with Yi.Config+ module Yi.Boot,+-- module Yi.Buffer.Misc,+ module Yi.Core,+ module Yi.Dired,+ module Yi.File,+ module Yi.Config,+ module Yi.Config.Default,+ module Yi.Layout,+ module Yi.Search,+ module Yi.Style,+ module Yi.Style.Library,+ module Yi.Misc,+ module Yi.Mode.Haskell,+#ifdef SCION+ module Yi.Scion,+#endif+ ) where++import Yi.Boot+--import Yi.Buffer.Misc hiding(modifyMode)+import Yi.Core hiding(modifyMode, (%=))+import Yi.Config.Default+import Yi.Config.Misc+import Yi.Config.Simple.Types+import Yi.Dired+import Yi.Eval+import Yi.File+import Yi.Layout+import Yi.Search+import Yi.Style+import Yi.Style.Library+import Yi.Misc+import Yi.Mode.Haskell+#ifdef SCION+import Yi.Scion+#endif++import Text.Printf(printf)+import Prelude hiding((.))++import Control.Monad.State hiding (modify, get)++-- we do explicit imports because we reuse a lot of the names+import Yi.Config(Config, UIConfig,+ startFrontEndA, configUIA, startActionsA, initialActionsA, defaultKmA, + configInputPreprocessA, modeTableA, debugModeA,+ configRegionStyleA, configKillringAccumulateA, bufferUpdateHandlerA,+ configVtyEscDelayA, configFontNameA, configFontSizeA, configScrollWheelAmountA,+ configScrollStyleA, configCursorStyleA, CursorStyle(..),+ configLeftSideScrollBarA, configAutoHideScrollBarA, configAutoHideTabBarA,+ configLineWrapA, configWindowFillA, configThemeA, layoutManagersA, configVarsA,+ )+import Data.Maybe(mapMaybe)++{- $overview+This module provides a simple configuration API, allowing users to start with an initial+configuration and imperatively (monadically) modify it. Some common actions (keybindings, +selecting modes, choosing the frontend) have been given special commands ('globalBindKeys',+'setFrontendPreferences', 'addMode', and so on).++A simple configuration might look like the following:++@import Yi.Config.Simple+import qualified Yi.Mode.Haskell as Haskell+-- note: don't import "Yi", or else there will be name clashes++main = 'configMain' 'defaultEmacsConfig' $ do+ 'setFrontendPreferences' ["pango", "vte", "vty"]+ 'fontSize' '%=' 'Just' 10+ 'modeBindKeys' Haskell.cleverMode ('metaCh' \'q\' '?>>!' 'reload')+ 'globalBindKeys' ('metaCh' \'r\' '?>>!' 'reload')@++A lot of the fields here are specified with the 'Field' type. To write a field, use ('%='). To read, use 'get'. For modification, use ('modify'). For example, the functions @foo@ and @bar@ are equivalent:++@foo = 'modify' 'layoutManagers' 'reverse'+bar = do+ lms <- 'get' 'layoutManagers'+ 'layoutManagers' '%=' 'reverse' lms@+-}++++--------------- Main interface+-- newtype ConfigM a (imported)++-- | Starts with the given initial config, makes the described modifications, then starts yi.+configMain :: Config -> ConfigM () -> IO ()+configMain c m = yi =<< execStateT (runConfigM m) c++-- type Field a (imported++-- | Set a field.+(%=) :: Field a -> a -> ConfigM ()+(%=) = putA++-- | Get a field.+get :: Field a -> ConfigM a+get = getA++-- | Modify a field.+modify :: Field a -> (a -> a) -> ConfigM ()+modify = modA+++---------------------------------- Frontend+-- | Sets the frontend to the first frontend from the list which is installed.+--+-- Available frontends are a subset of: \"vte\", \"vty\", \"pango\", \"cocoa\", and \"batch\".+setFrontendPreferences :: [String] -> ConfigM ()+setFrontendPreferences fs = + case mapMaybe (\f -> lookup f availableFrontends) fs of+ (f:_) -> startFrontEndA %= f+ [] -> return ()++-- | Sets the frontend, if it is available.+setFrontend :: String -> ConfigM ()+setFrontend f = maybe (return ()) (startFrontEndA %=) (lookup f availableFrontends)++------------------------- Modes, commands, and keybindings+-- | Adds the given key bindings to the `global keymap'. The bindings will override existing bindings in the case of a clash.+globalBindKeys :: Keymap -> ConfigM ()+globalBindKeys a = modify (topKeymapA . defaultKmA) (||> a)++-- | @modeBindKeys mode keys@ adds the keybindings in @keys@ to all modes with the same name as @mode@.+--+-- As with 'modifyMode', a mode by the given name must already be registered, or the function will+-- have no effect, and issue a command-line warning.+modeBindKeys :: Mode syntax -> Keymap -> ConfigM ()+modeBindKeys mode keys = ensureModeRegistered "modeBindKeys" (modeName mode) $ modeBindKeysByName (modeName mode) keys++-- | @modeBindKeysByName name keys@ adds the keybindings in @keys@ to all modes with name @name@ (if it is registered). Consider using 'modeBindKeys' instead.+modeBindKeysByName :: String -> Keymap -> ConfigM ()+modeBindKeysByName name k = ensureModeRegistered "modeBindKeysByName" name $ modifyModeByName name (modeKeymapA ^: f) + where+ f :: (KeymapSet -> KeymapSet) -> (KeymapSet -> KeymapSet)+ f mkm km = topKeymapA ^: (||> k) $ mkm km+-- (modeKeymapA ^: ((topKeymap ^: (||> k)) .))++-- | Register the given mode. It will be preferred over any modes already defined.+addMode :: Mode syntax -> ConfigM ()+addMode m = modify modeTableA (AnyMode m :)++-- | @modifyMode mode f@ modifies all modes with the same name as @mode@, using the function @f@. +--+-- Note that the @mode@ argument is only used by its 'modeName'. In particular, a mode by the given name+-- must already be registered, or this function will have no effect, and issue a command-line warning.+--+-- @'modifyMode' mode f = 'modifyModeByName' ('modeName' mode) f@+modifyMode :: Mode syntax -> (forall syntax'. Mode syntax' -> Mode syntax') -> ConfigM ()+modifyMode mode f = ensureModeRegistered "modifyMode" (modeName mode) $ modifyModeByName (modeName mode) f++-- | @modifyModeByName name f@ modifies the mode with name @name@ using the function @f@. Consider using 'modifyMode' instead.+modifyModeByName :: String -> (forall syntax. Mode syntax -> Mode syntax) -> ConfigM ()+modifyModeByName name f = ensureModeRegistered "modifyModeByName" name $ modify modeTableA (fmap (onMode g))+ where+ g :: forall syntax. Mode syntax -> Mode syntax+ g m | modeName m == name = f m+ | otherwise = m++-- helper functions+warn :: String -> String -> ConfigM ()+warn caller msg = io $ putStrLn $ printf "Warning: %s: %s" caller msg+-- the putStrLn shouldn't be necessary, but it doesn't print anything if it's not there...++isModeRegistered :: String -> ConfigM Bool+isModeRegistered name = (Prelude.any (\(AnyMode mode) -> modeName mode == name)) <$> get modeTableA++-- ensure the given mode is registered, and if it is, then run the given action.+ensureModeRegistered :: String -> String -> ConfigM () -> ConfigM ()+ensureModeRegistered caller name m = do+ isRegistered <- isModeRegistered name+ if isRegistered+ then m+ else warn caller (printf "mode \"%s\" is not registered." name) ++--------------------- Appearance+-- | 'Just' the font name, or 'Nothing' for default.+fontName :: Field (Maybe String)+fontName = configFontNameA . configUIA++-- | 'Just' the font size, or 'Nothing' for default.+fontSize :: Field (Maybe Int)+fontSize = configFontSizeA . configUIA++-- | Amount to move the buffer when using the scroll wheel.+scrollWheelAmount :: Field Int+scrollWheelAmount = configScrollWheelAmountA . configUIA++-- | 'Just' the scroll style, or 'Nothing' for default.+scrollStyle :: Field (Maybe ScrollStyle)+scrollStyle = configScrollStyleA . configUIA++-- | See 'CursorStyle' for documentation.+cursorStyle :: Field CursorStyle+cursorStyle = configCursorStyleA . configUIA++data Side = LeftSide | RightSide++-- | Which side to display the scroll bar on.+scrollBarSide :: Field Side+scrollBarSide = fromBool . configLeftSideScrollBarA . configUIA + where+ fromBool :: Accessor Bool Side+ fromBool = accessor (\b -> if b then LeftSide else RightSide) (\s _ -> case s of { LeftSide -> True; RightSide -> False }) ++-- | Should the scroll bar autohide?+autoHideScrollBar :: Field Bool+autoHideScrollBar = configAutoHideScrollBarA . configUIA++-- | Should the tab bar autohide?+autoHideTabBar :: Field Bool+autoHideTabBar = configAutoHideTabBarA . configUIA++-- | Should lines be wrapped?+lineWrap :: Field Bool+lineWrap = configLineWrapA . configUIA++-- | The character with which to fill empty window space. Usually \'~\' for vi-like editors, \' \' for everything else.+windowFill :: Field Char+windowFill = configWindowFillA . configUIA++-- | UI colour theme.+theme :: Field Theme+theme = configThemeA . configUIA++---------- Layout+-- | List of registered layout managers. When cycling through layouts, this list will be consulted.+layoutManagers :: Field [AnyLayoutManager]+layoutManagers = layoutManagersA++------------------------ Debugging+-- | Produce a .yi.dbg file with debugging information?+debug :: Field Bool+debug = debugModeA++----------- Startup hooks+-- | Run when the editor is started (this is run after all actions which have already been registered)+runOnStartup :: Action -> ConfigM ()+runOnStartup action = runManyOnStartup [action]++-- | List version of 'runOnStartup'.+runManyOnStartup :: [Action] -> ConfigM ()+runManyOnStartup actions = modify startActions (++actions)++-- | Run after the startup actions have completed, or on reload (this is run after all actions which have already been registered)+runAfterStartup :: Action -> ConfigM ()+runAfterStartup action = runManyAfterStartup [action]++-- | List version of 'runAfterStartup'.+runManyAfterStartup :: [Action] -> ConfigM ()+runManyAfterStartup actions = modify initialActions (++actions)++------------------------ Advanced+{- $advanced++These fields are here for completeness -- that is, to expose all the functionality +of the "Yi.Config" module. However, most users probably need not use these fields,+typically because they provide advanced functinality, or because a simpler interface+for the common case is available above.++-}++-- | Actions to run when the editor is started. Consider using 'runOnStartup' or 'runManyOnStartup' instead.+startActions :: Field [Action]+startActions = startActionsA++-- | Actions to run after startup or reload. Consider using 'runAfterStartup' or 'runManyAfterStartup' instead.+initialActions :: Field [Action]+initialActions = initialActionsA++-- | Default keymap to use.+defaultKm :: Field KeymapSet+defaultKm = defaultKmA++-- | ?+inputPreprocess :: Field (P Event Event)+inputPreprocess = configInputPreprocessA++-- | List of modes by order of preference. Consider using 'addMode', 'modeBindKeys', or 'modifyMode' instead.+modes :: Field [AnyMode]+modes = modeTableA++-- | Set to 'Exclusive' for an emacs-like behaviour. Consider starting with 'defaultEmacsConfig', 'defaultVimConfig', or 'defaultCuaConfig' to instead.+regionStyle :: Field RegionStyle+regionStyle = configRegionStyleA++-- | Set to 'True' for an emacs-like behaviour, where all deleted text is accumulated in a killring. Consider starting with 'defaultEmacsConfig', 'defaultVimConfig', or 'defaultCuaConfig' instead.+killringAccumulate :: Field Bool+killringAccumulate = configKillringAccumulateA++-- | ?+bufferUpdateHandler :: Field [[Update] -> BufferM ()]+bufferUpdateHandler = bufferUpdateHandlerA+
+ src/library/Yi/Config/Simple/Types.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | exports from "Yi.Config.Simple" which are useful to \"core yi\" rather than just config files.+module Yi.Config.Simple.Types+ where++import Prelude()+import Yi.Prelude+import Yi.Config+import Yi.Dynamic+import Control.Monad.State hiding (modify, get)++-- | The configuration monad. Run it with 'configMain'.+newtype ConfigM a = ConfigM { runConfigM :: StateT Config IO a } deriving(Monad, Functor, Applicative, MonadState Config, MonadIO)++-- | Fields that can be modified with ('%='), 'get' and 'modify'.+type Field a = Accessor Config a++{- | Accessor for any 'YiConfigVariable', to be used by modules defining+'YiConfigVariable's. Such modules should provide a custom-named field.+For instance, take the following hypothetical 'YiConfigVariable':++@newtype UserName = UserName { unUserName :: String }+ deriving(Typeable, Binary, Initializable)+instance YiConfigVariable UserName++$(nameDeriveAccessors ''UserName (\n -> Just (n ++ \"A\")))++userName :: 'Field' 'String'+userName = unUserNameA '.' 'customVariable'@++Here, the hypothetical library would provide the field @userName@ to be used in preference to @customVariable@.+-}+customVariable :: YiConfigVariable a => Field a+customVariable = configVariableA . configVarsA
src/library/Yi/Core.hs view
@@ -67,7 +67,6 @@ import System.Exit import System.FilePath import System.IO (Handle, hWaitForInput, hPutStr)-import qualified System.IO.UTF8 as UTF8 import System.PosixCompat.Files import System.Process (terminateProcess, getProcessExitCode, ProcessHandle) @@ -218,7 +217,7 @@ modTime <- fileModTime fname if b ^. lastSyncTimeA < modTime then if isUnchangedBuffer b- then do newContents <- UTF8.readFile fname+ then do newContents <- R.readFile fname return (snd $ runBuffer (dummyWindow $ bkey b) b (revertB newContents now), Just msg1) else do return (b, Just msg2) else nothing
src/library/Yi/Debug.hs view
@@ -69,7 +69,7 @@ logStream :: Show a => String -> Chan a -> IO () logStream msg ch = do logPutStrLn $ "Logging stream " ++ msg- forkIO $ logStreamThread msg ch+ _ <- forkIO $ logStreamThread msg ch return () logStreamThread :: Show a => String -> Chan a -> IO ()
src/library/Yi/Dired.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} -- Copyright (c) 2007, 2008, 2009 Ben Moseley, Wen Pu @@ -30,28 +30,28 @@ import qualified Codec.Binary.UTF8.String as UTF8 import Control.Monad.Reader hiding (mapM)+import Data.Binary import Data.List hiding (find, maximum, concat) import Data.Maybe import Data.Char (toLower)+import Data.DeriveTH import qualified Data.Map as M import qualified Data.Rope as R import Data.Time import Data.Time.Clock.POSIX-import System.Directory+import System.Directory hiding (canonicalizePath) import System.FilePath-import System.FriendlyPath+import System.CanonicalizePath (canonicalizePath) import System.Locale import System.PosixCompat.Files import System.PosixCompat.Types import System.PosixCompat.User import Text.Printf -import Yi.Config import Yi.Core hiding (sequence, forM, notElem) import {-# source #-} Yi.File (editFile) import Yi.MiniBuffer (spawnMinibufferE, withMinibufferGen, noHint, withMinibuffer) import Yi.Misc (getFolder, promptFile)-import Yi.Regex import Yi.Style data DiredFileInfo = DiredFileInfo { permString :: String@@ -84,6 +84,8 @@ } deriving (Show, Eq, Typeable) +$(derive makeBinary ''DiredState)+ instance Initializable DiredState where initial = DiredState { diredPath = "" , diredMarks = M.empty@@ -93,6 +95,10 @@ , diredCurrFile = "" } +instance YiVariable DiredState++$(derives [makeBinary] [''DiredEntry, ''DiredFileInfo])+ bypassReadOnly :: BufferM a -> BufferM a bypassReadOnly f = do ro <- getA readOnlyA putA readOnlyA False@@ -103,6 +109,193 @@ filenameColOf :: BufferM () -> BufferM () filenameColOf f = getA bufferDynamicValueA >>= setPrefCol . Just . diredNameCol >> f +resetDiredOpState :: YiM ()+resetDiredOpState = withBuffer $ modA bufferDynamicValueA (\_ds -> initial :: DiredOpState)++incDiredOpSucCnt :: YiM ()+incDiredOpSucCnt = withBuffer $ modA bufferDynamicValueA (\ds -> ds { diredOpSucCnt = (diredOpSucCnt ds) + 1 })++getDiredOpState :: YiM DiredOpState+getDiredOpState = withBuffer $ getA bufferDynamicValueA++modDiredOpState :: (DiredOpState -> DiredOpState) -> YiM ()+modDiredOpState f = withBuffer $ modA bufferDynamicValueA f++-- | execute the operations+-- Pass the list of remaining operations down, insert new ops at the head if needed+procDiredOp :: Bool -> [DiredOp] -> YiM ()+procDiredOp counting ((DORemoveFile f):ops) = do+ io $ catch (removeLink f) handler+ when counting postproc+ procDiredOp counting ops+ where handler err = fail $ concat ["Remove file ", f,+ " failed: ", show err]+ postproc = do incDiredOpSucCnt+ withBuffer $ diredUnmarkPath (takeFileName f)+procDiredOp counting ((DORemoveDir f):ops) = do+ io $ catch (removeDirectoryRecursive f) handler+ -- document suggests removeDirectoryRecursive will follow+ -- symlinks in f, but it seems not the case, at least on OS X.+ when counting postproc+ procDiredOp counting ops+ where handler err = fail $ concat ["Remove directory ", f,+ " failed: ", show err]+ postproc = do+ incDiredOpSucCnt+ withBuffer $ diredUnmarkPath (takeFileName f)+procDiredOp _counting ((DORemoveBuffer _):_) = undefined -- TODO+procDiredOp counting ((DOCopyFile o n):ops) = do+ io $ catch (copyFile o n) handler+ when counting postproc+ procDiredOp counting ops+ where handler err = fail $ concat ["Copy file ", o,+ " to ", n, " failed: ", show err]+ postproc = do+ incDiredOpSucCnt+ withBuffer $ diredUnmarkPath (takeFileName o)+ -- TODO: mark copied files with "C" if the target dir's dired buffer exists+procDiredOp counting ((DOCopyDir o n):ops) = do+ contents <- io $ catch doCopy handler+ subops <- io $ mapM builder $ filter (`notElem` [".", ".."]) contents+ procDiredOp False subops+ when counting postproc+ procDiredOp counting ops+ where handler err = fail $ concat ["Copy directory ", o, " to ", n, " failed: ", show err]+ postproc = do+ incDiredOpSucCnt+ withBuffer $ diredUnmarkPath (takeFileName o)+ -- perform dir copy: create new dir and create other copy ops+ doCopy :: IO [FilePath]+ doCopy = do+ exists <- doesDirectoryExist n+ when exists $ removeDirectoryRecursive n+ createDirectoryIfMissing True n+ getDirectoryContents o+ -- build actual copy operations+ builder :: FilePath -> IO DiredOp+ builder name = do+ let npath = n </> name+ let opath = o </> name+ isDir <- doesDirectoryExist opath+ return $ DOCkOverwrite npath $ (getOp isDir) opath npath+ where getOp isDir = if isDir then DOCopyDir else DOCopyFile+++procDiredOp counting ((DORename o n):ops) = do+ io $ catch (rename o n) handler+ when counting postproc+ procDiredOp counting ops+ where handler err = fail $ concat ["Rename ", o,+ " to ", n, " failed: ", show err]+ postproc = do+ incDiredOpSucCnt+ withBuffer $ diredUnmarkPath (takeFileName o)+procDiredOp counting r@((DOConfirm prompt eops enops):ops) = do+ withMinibuffer (prompt ++ " (yes/no)") noHint act+ where act s = case map toLower s of+ "yes" -> procDiredOp counting (eops ++ ops)+ "no" -> procDiredOp counting (enops ++ ops)+ _ -> procDiredOp counting r+ -- TODO: show an error msg+procDiredOp counting ((DOCheck check eops enops):ops) = do+ res <- io $ check+ if res then procDiredOp counting (eops ++ ops)+ else procDiredOp counting (enops ++ ops)+procDiredOp counting ((DOCkOverwrite fp op):ops) = do+ exists <- io $ fileExist fp+ if exists then procDiredOp counting (newOp:ops)+ else procDiredOp counting (op:ops)+ where newOp = DOChoice (concat ["Overwrite ", fp, " ?"]) op+procDiredOp counting ((DOInput prompt opGen):ops) = do+ promptFile prompt act+ where act s = do procDiredOp counting $ (opGen s) ++ ops+procDiredOp counting ((DONoOp):ops) = procDiredOp counting ops+procDiredOp counting ((DOFeedback f):ops) = do+ getDiredOpState >>= f >> procDiredOp counting ops+procDiredOp counting r@((DOChoice prompt op):ops) = do+ st <- getDiredOpState+ if diredOpForAll st then proceedYes+ else discard $ withEditor $ spawnMinibufferE msg (const askKeymap)+ where msg = concat [prompt, " (y/n/!/q/h)"]+ askKeymap = choice ([ char 'n' ?>>! noAction+ , char 'y' ?>>! yesAction+ , char '!' ?>>! allAction+ , char 'q' ?>>! quit+ , char 'h' ?>>! help+ ])+ noAction = cleanUp >> proceedNo+ yesAction = cleanUp >> proceedYes+ allAction = do cleanUp+ modDiredOpState (\st -> st{diredOpForAll=True})+ proceedYes+ quit = cleanUp >> msgEditor "Quit"+ help = do msgEditor $ concat ["y: yes, n: no, ",+ "!: yes on all remaining items, ",+ "q: quit, h: help"]+ cleanUp+ procDiredOp counting r -- repeat+ -- use cleanUp to get back the original buffer+ cleanUp = withEditor closeBufferAndWindowE+ proceedYes = procDiredOp counting (op:ops)+ proceedNo = procDiredOp counting ops+procDiredOp _ _ = return ()+++-- | delete a list of file in the given directory+-- 1. Ask for confirmation, if yes, perform deletions, otherwise showNothing+-- 2. Confirmation is required for recursive deletion of non-empty directry, but only the top level one+-- 3. Show the number of successful deletions at the end of the excution+-- 4. TODO: ask confirmation for wether to remove the associated buffers when a file is removed+askDelFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()+askDelFiles dir fs = do+ case fs of+ (_x:_) -> do+ resetDiredOpState+ -- TODO: show the file name list in new tmp window+ opList <- io $ sequence ops+ -- a deletion command is mapped to a list of deletions wrapped up by DOConfirm+ -- TODO: is `counting' necessary here?+ procDiredOp True [DOConfirm prompt (opList ++ [DOFeedback showResult]) [DOFeedback showNothing]]+ -- no files listed+ [] -> procDiredOp True [DOFeedback showNothing]+ where prompt = concat ["Delete ", show $ length fs, " file(s)?"]+ ops = (map opGenerator fs)+ showResult st = do+ diredRefresh+ msgEditor $ concat [show $ diredOpSucCnt st, " of ",+ show total, " deletions done"]+ showNothing _ = msgEditor "(No deletions requested)"+ total = length fs+ opGenerator :: (FilePath, DiredEntry) -> IO DiredOp+ opGenerator (fn, de) = do+ exists <- fileExist path+ if exists then case de of+ (DiredDir _dfi) -> do+ isNull <- liftM nullDir $ getDirectoryContents path+ return $ if isNull then (DOConfirm recDelPrompt [DORemoveDir path] [DONoOp])+ else (DORemoveDir path)+ _ -> return (DORemoveFile path)+ else return DONoOp+ where path = dir </> fn+ recDelPrompt = concat ["Recursive delete of ", fn, "?"]+ -- Test the emptyness of a folder+ nullDir :: [FilePath] -> Bool+ nullDir contents = Data.List.any (not . flip Data.List.elem [".", ".."]) contents++diredDoDel :: YiM ()+diredDoDel = do+ dir <- currentDir+ maybefile <- withBuffer fileFromPoint+ case maybefile of+ Just (fn, de) -> askDelFiles dir [(fn, de)]+ Nothing -> noFileAtThisLine++diredDoMarkedDel :: YiM ()+diredDoMarkedDel = do+ dir <- currentDir+ fs <- markedFiles (flip Data.List.elem ['D'])+ askDelFiles dir fs+ diredKeymap :: Keymap -> Keymap diredKeymap = do (choice [@@ -134,7 +327,9 @@ diredDir dir = diredDirBuffer dir >> return () diredDirBuffer :: FilePath -> YiM BufferRef-diredDirBuffer dir = do+diredDirBuffer d = do+ -- Emacs doesn't follow symlinks, probbably Yi shouldn't do too+ dir <- io $ canonicalizePath d -- XXX Don't specify the path as the filename of the buffer. b <- withEditor $ stringToNewBuffer (Left dir) (R.fromString "") withEditor $ switchToBufferE b@@ -247,8 +442,7 @@ files <- getDirectoryContents dir -- The file strings as UTF-8 encoded on linux. They need to stay this way for functions that -- stat these paths. However for display they need to be converted to ISO-10646 strings.- let filteredFiles = filter (not . diredOmitFile) files- foldM (lineForFile dir) M.empty filteredFiles+ foldM (lineForFile dir) M.empty files where lineForFile :: String -> M.Map FilePath DiredEntry -> String -> IO (M.Map FilePath DiredEntry) lineForFile d m f = do@@ -315,8 +509,9 @@ shortCalendarTimeToString = formatTime defaultTimeLocale "%b %d %H:%M" -- Default Filter: omit files ending in '~' or '#' and also '.' and '..'.-diredOmitFile :: String -> Bool-diredOmitFile = (=~".*~$|.*#$|^\\.$|^\\..$|.*\\.pyc$")+-- TODO: customizable filters?+--diredOmitFile :: String -> Bool+--diredOmitFile = undefined diredMark :: BufferM () diredMark = diredMarkWithChar '*' lineDown@@ -378,22 +573,104 @@ currentDir = do DiredState { diredPath = dir } <- withBuffer $ getA bufferDynamicValueA return dir- -diredDoDel :: YiM ()-diredDoDel = do- dir <- currentDir- maybefile <- withBuffer fileFromPoint- case maybefile of- Just (fn, de) -> askDelFiles dir [(fn, de)]- Nothing -> noFileAtThisLine --diredDoMarkedDel :: YiM ()-diredDoMarkedDel = do- dir <- currentDir- fs <- markedFiles (flip Data.List.elem ['D'])- askDelFiles dir fs+-- | move selected files in a given directory to the target location given+-- by user input+--+-- if multiple source+-- then if target is not a existing dir+-- then error+-- else move source files into target dir+-- else if target is dir+-- then if target exist+-- then move source file into target dir+-- else if source is dir and parent of target exists+-- then move source to target+-- else error+-- else if parent of target exist+-- then move source to target+-- else error+askRenameFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()+askRenameFiles dir fs =+ case fs of+ (_x:[]) -> do resetDiredOpState+ procDiredOp True [DOInput prompt $ sOpIsDir]+ (_x:_) -> do resetDiredOpState+ procDiredOp True [DOInput prompt $ mOpIsDirAndExists]+ [] -> procDiredOp True [DOFeedback showNothing]+ where prompt = concat ["Move ", show total, " item(s) to:"]+ mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]+ where+ posOps = (map builder fs) ++ [DOFeedback showResult]+ negOps = [DOFeedback (\_ -> errorEditor $ concat [t, " is not directory!"])]+ builder (fn, _de) = let old = dir </> fn+ new = t </> fn+ in DOCkOverwrite new (DORename old new)+ sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirRename]+ where (fn, _) = head fs -- the only item+ posOps = [DOCkOverwrite new (DORename old new),+ DOFeedback showResult]+ where new = t </> fn+ old = dir </> fn+ sOpDirRename = [DOCheck ckParentDir posOps' negOps,+ DOFeedback showResult]+ where posOps' = [DOCkOverwrite new (DORename old new)]+ negOps =+ [DOFeedback (\_ -> errorEditor $ concat ["Cannot move ", old, " to ", new])]+ new = t+ old = dir </> fn+ ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t)+ showResult st = do+ diredRefresh+ msgEditor $ concat [show (diredOpSucCnt st),+ " of ", show total, " item(s) moved."]+ showNothing _ = msgEditor $ "Quit"+ total = length fs +-- | copy selected files in a given directory to the target location given+-- by user input+-- +-- askCopyFiles follow the same logic as askRenameFiles,+-- except dir and file are done by different DiredOP+askCopyFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()+askCopyFiles dir fs = do+ case fs of+ (_x:[]) -> do resetDiredOpState+ procDiredOp True [DOInput prompt $ sOpIsDir]+ (_x:_) -> do resetDiredOpState+ procDiredOp True [DOInput prompt $ mOpIsDirAndExists]+ [] -> procDiredOp True [DOFeedback showNothing]+ where prompt = concat ["Copy ", show total, " item(s) to:"]+ mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]+ where+ posOps = (map builder fs) ++ [DOFeedback showResult]+ negOps = [DOFeedback (\_ -> errorEditor $ concat [t, " is not directory!"])]+ builder (fn, de) = let old = dir </> fn+ new = t </> fn+ in DOCkOverwrite new ((op4Type de) old new)+ sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirCopy]+ where (fn, de) = head fs -- the only item+ posOps = [DOCkOverwrite new ((op4Type de) old new),+ DOFeedback showResult]+ where new = t </> fn+ old = dir </> fn+ sOpDirCopy = [DOCheck ckParentDir posOps' negOps,+ DOFeedback showResult]+ where posOps' = [DOCkOverwrite new ((op4Type de) old new)]+ negOps =+ [DOFeedback (\_ -> errorEditor $ concat ["Cannot copy ", old, " to ", new])]+ new = t+ old = dir </> fn+ ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t)+ showResult st = do+ diredRefresh+ msgEditor $ concat [show (diredOpSucCnt st),+ " of ", show total, " item(s) copied."]+ showNothing _ = msgEditor $ "Quit"+ total = length fs+ op4Type :: DiredEntry -> FilePath -> FilePath -> DiredOp+ op4Type (DiredDir _) = DOCopyDir+ op4Type _ = DOCopyFile diredRename :: YiM () diredRename = do@@ -535,279 +812,7 @@ instance Initializable DiredOpState where initial = DiredOpState {diredOpSucCnt = 0, diredOpForAll = False} -incDiredOpSucCnt :: YiM ()-incDiredOpSucCnt = withBuffer $ modA bufferDynamicValueA (\ds -> ds { diredOpSucCnt = (diredOpSucCnt ds) + 1 })--resetDiredOpState :: YiM ()-resetDiredOpState = withBuffer $ modA bufferDynamicValueA (\_ds -> initial :: DiredOpState)--getDiredOpState :: YiM DiredOpState-getDiredOpState = withBuffer $ getA bufferDynamicValueA--modDiredOpState :: (DiredOpState -> DiredOpState) -> YiM ()-modDiredOpState f = withBuffer $ modA bufferDynamicValueA f---- | execute the operations--- Pass the list of remaining operations down, insert new ops at the head if needed-procDiredOp :: Bool -> [DiredOp] -> YiM ()-procDiredOp counting ((DORemoveFile f):ops) = do- io $ catch (removeLink f) handler- when counting postproc- procDiredOp counting ops- where handler err = fail $ concat ["Remove file ", f,- " failed: ", show err]- postproc = do incDiredOpSucCnt- withBuffer $ diredUnmarkPath (takeFileName f)-procDiredOp counting ((DORemoveDir f):ops) = do- io $ catch (removeDirectoryRecursive f) handler- -- document suggests removeDirectoryRecursive will follow- -- symlinks in f, but it seems not the case, at least on OS X.- when counting postproc- procDiredOp counting ops- where handler err = fail $ concat ["Remove directory ", f,- " failed: ", show err]- postproc = do- incDiredOpSucCnt- withBuffer $ diredUnmarkPath (takeFileName f)-procDiredOp _counting ((DORemoveBuffer _):_) = undefined -- TODO-procDiredOp counting ((DOCopyFile o n):ops) = do- io $ catch (copyFile o n) handler- when counting postproc- procDiredOp counting ops- where handler err = fail $ concat ["Copy file ", o,- " to ", n, " failed: ", show err]- postproc = do- incDiredOpSucCnt- withBuffer $ diredUnmarkPath (takeFileName o)- -- TODO: mark copied files with "C" if the target dir's dired buffer exists-procDiredOp counting ((DOCopyDir o n):ops) = do- contents <- io $ catch doCopy handler- subops <- io $ mapM builder $ filter (`notElem` [".", ".."]) contents- procDiredOp False subops- when counting postproc- procDiredOp counting ops- where handler err = fail $ concat ["Copy directory ", o, " to ", n, " failed: ", show err]- postproc = do- incDiredOpSucCnt- withBuffer $ diredUnmarkPath (takeFileName o)- -- perform dir copy: create new dir and create other copy ops- doCopy :: IO [FilePath]- doCopy = do- exists <- doesDirectoryExist n- when exists $ removeDirectoryRecursive n- createDirectoryIfMissing True n- getDirectoryContents o- -- build actual copy operations- builder :: FilePath -> IO DiredOp- builder name = do- let npath = n </> name- let opath = o </> name- isDir <- doesDirectoryExist opath- return $ DOCkOverwrite npath $ (getOp isDir) opath npath- where getOp isDir = if isDir then DOCopyDir else DOCopyFile---procDiredOp counting ((DORename o n):ops) = do- io $ catch (rename o n) handler- when counting postproc- procDiredOp counting ops- where handler err = fail $ concat ["Rename ", o,- " to ", n, " failed: ", show err]- postproc = do- incDiredOpSucCnt- withBuffer $ diredUnmarkPath (takeFileName o)-procDiredOp counting r@((DOConfirm prompt eops enops):ops) = do- withMinibuffer (prompt ++ " (yes/no)") noHint act- where act s = case map toLower s of- "yes" -> procDiredOp counting (eops ++ ops)- "no" -> procDiredOp counting (enops ++ ops)- _ -> procDiredOp counting r- -- TODO: show an error msg-procDiredOp counting ((DOCheck check eops enops):ops) = do- res <- io $ check- if res then procDiredOp counting (eops ++ ops)- else procDiredOp counting (enops ++ ops)-procDiredOp counting ((DOCkOverwrite fp op):ops) = do- exists <- io $ fileExist fp- if exists then procDiredOp counting (newOp:ops)- else procDiredOp counting (op:ops)- where newOp = DOChoice (concat ["Overwrite ", fp, " ?"]) op-procDiredOp counting ((DOInput prompt opGen):ops) = do- promptFile prompt act- where act s = do procDiredOp counting $ (opGen s) ++ ops-procDiredOp counting ((DONoOp):ops) = procDiredOp counting ops-procDiredOp counting ((DOFeedback f):ops) = do- getDiredOpState >>= f >> procDiredOp counting ops-procDiredOp counting r@((DOChoice prompt op):ops) = do- st <- getDiredOpState- if diredOpForAll st then proceedYes- else discard $ withEditor $ spawnMinibufferE msg (const askKeymap)- where msg = concat [prompt, " (y/n/!/q/h)"]- askKeymap = choice ([ char 'n' ?>>! noAction- , char 'y' ?>>! yesAction- , char '!' ?>>! allAction- , char 'q' ?>>! quit- , char 'h' ?>>! help- ])- noAction = cleanUp >> proceedNo- yesAction = cleanUp >> proceedYes- allAction = do cleanUp- modDiredOpState (\st -> st{diredOpForAll=True})- proceedYes- quit = cleanUp >> msgEditor "Quit"- help = do msgEditor $ concat ["y: yes, n: no, ",- "!: yes on all remaining items, ",- "q: quit, h: help"]- cleanUp- procDiredOp counting r -- repeat- -- use cleanUp to get back the original buffer- cleanUp = withEditor closeBufferAndWindowE- proceedYes = procDiredOp counting (op:ops)- proceedNo = procDiredOp counting ops-procDiredOp _ _ = return ()------- | move selected files in a given directory to the target location given--- by user input------ if multiple source--- then if target is not a existing dir--- then error--- else move source files into target dir--- else if target is dir--- then if target exist--- then move source file into target dir--- else if source is dir and parent of target exists--- then move source to target--- else error--- else if parent of target exist--- then move source to target--- else error-askRenameFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()-askRenameFiles dir fs =- case fs of- (_x:[]) -> do resetDiredOpState- procDiredOp True [DOInput prompt $ sOpIsDir]- (_x:_) -> do resetDiredOpState- procDiredOp True [DOInput prompt $ mOpIsDirAndExists]- [] -> procDiredOp True [DOFeedback showNothing]- where prompt = concat ["Move ", show total, " item(s) to:"]- mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]- where- posOps = (map builder fs) ++ [DOFeedback showResult]- negOps = [DOFeedback (\_ -> errorEditor $ concat [t, " is not directory!"])]- builder (fn, _de) = let old = dir </> fn- new = t </> fn- in DOCkOverwrite new (DORename old new)- sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirRename]- where (fn, _) = head fs -- the only item- posOps = [DOCkOverwrite new (DORename old new),- DOFeedback showResult]- where new = t </> fn- old = dir </> fn- sOpDirRename = [DOCheck ckParentDir posOps' negOps,- DOFeedback showResult]- where posOps' = [DOCkOverwrite new (DORename old new)]- negOps =- [DOFeedback (\_ -> errorEditor $ concat ["Cannot move ", old, " to ", new])]- new = t- old = dir </> fn- ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t)- showResult st = do- diredRefresh- msgEditor $ concat [show (diredOpSucCnt st),- " of ", show total, " item(s) moved."]- showNothing _ = msgEditor $ "Quit"- total = length fs----- | copy selected files in a given directory to the target location given--- by user input--- --- askCopyFiles follow the same logic as askRenameFiles,--- except dir and file are done by different DiredOP-askCopyFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()-askCopyFiles dir fs = do- case fs of- (_x:[]) -> do resetDiredOpState- procDiredOp True [DOInput prompt $ sOpIsDir]- (_x:_) -> do resetDiredOpState- procDiredOp True [DOInput prompt $ mOpIsDirAndExists]- [] -> procDiredOp True [DOFeedback showNothing]- where prompt = concat ["Copy ", show total, " item(s) to:"]- mOpIsDirAndExists t = [DOCheck (doesDirectoryExist t) posOps negOps]- where- posOps = (map builder fs) ++ [DOFeedback showResult]- negOps = [DOFeedback (\_ -> errorEditor $ concat [t, " is not directory!"])]- builder (fn, de) = let old = dir </> fn- new = t </> fn- in DOCkOverwrite new ((op4Type de) old new)- sOpIsDir t = [DOCheck (doesDirectoryExist t) posOps sOpDirCopy]- where (fn, de) = head fs -- the only item- posOps = [DOCkOverwrite new ((op4Type de) old new),- DOFeedback showResult]- where new = t </> fn- old = dir </> fn- sOpDirCopy = [DOCheck ckParentDir posOps' negOps,- DOFeedback showResult]- where posOps' = [DOCkOverwrite new ((op4Type de) old new)]- negOps =- [DOFeedback (\_ -> errorEditor $ concat ["Cannot copy ", old, " to ", new])]- new = t- old = dir </> fn- ckParentDir = doesDirectoryExist $ takeDirectory (dropTrailingPathSeparator t)- showResult st = do- diredRefresh- msgEditor $ concat [show (diredOpSucCnt st),- " of ", show total, " item(s) copied."]- showNothing _ = msgEditor $ "Quit"- total = length fs- op4Type :: DiredEntry -> FilePath -> FilePath -> DiredOp- op4Type (DiredDir _) = DOCopyDir- op4Type _ = DOCopyFile--+$(derive makeBinary ''DiredOpState) +instance YiVariable DiredOpState --- | delete a list of file in the given directory--- 1. Ask for confirmation, if yes, perform deletions, otherwise showNothing--- 2. Confirmation is required for recursive deletion of non-empty directry, but only the top level one--- 3. Show the number of successful deletions at the end of the excution--- 4. TODO: ask confirmation for wether to remove the associated buffers when a file is removed-askDelFiles :: FilePath -> [(FilePath, DiredEntry)] -> YiM ()-askDelFiles dir fs = do- case fs of- (_x:_) -> do- resetDiredOpState- -- TODO: show the file name list in new tmp window- opList <- io $ sequence ops- -- a deletion command is mapped to a list of deletions wrapped up by DOConfirm- -- TODO: is `counting' necessary here?- procDiredOp True [DOConfirm prompt (opList ++ [DOFeedback showResult]) [DOFeedback showNothing]]- -- no files listed- [] -> procDiredOp True [DOFeedback showNothing]- where prompt = concat ["Delete ", show $ length fs, " file(s)?"]- ops = (map opGenerator fs)- showResult st = do- diredRefresh- msgEditor $ concat [show $ diredOpSucCnt st, " of ",- show total, " deletions done"]- showNothing _ = msgEditor "(No deletions requested)"- total = length fs- opGenerator :: (FilePath, DiredEntry) -> IO DiredOp- opGenerator (fn, de) = do- exists <- fileExist path- if exists then case de of- (DiredDir _dfi) -> do- isNull <- liftM nullDir $ getDirectoryContents path- return $ if isNull then (DOConfirm recDelPrompt [DORemoveDir path] [DONoOp])- else (DORemoveDir path)- _ -> return (DORemoveFile path)- else return DONoOp- where path = dir </> fn- recDelPrompt = concat ["Recursive delete of ", fn, "?"]- -- Test the emptyness of a folder- nullDir :: [FilePath] -> Bool- nullDir contents = Data.List.any (not . flip Data.List.elem [".", ".."]) contents
src/library/Yi/Dynamic.hs view
@@ -1,61 +1,147 @@-{-# LANGUAGE ScopedTypeVariables, MagicHash, ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables, MagicHash, ExistentialQuantification, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} -- Copyright (c) Jean-Philippe Bernardy 2005-2007. module Yi.Dynamic (- Initializable(..),- toDyn, fromDynamic, dynamicValueA, emptyDV,- Typeable, Dynamic, DynamicValues+ -- * Nonserializable (\"config\") dynamics+ YiConfigVariable,+ ConfigVariables, configVariableA,+ -- * Serializable dynamics+ YiVariable, + DynamicValues, dynamicValueA, ) where import Prelude () import Yi.Prelude -import GHC.Exts-import Data.Accessor-import Data.Maybe-import Data.Typeable-import Data.Map as M--- ------------------------------------------------------------------------ | Class of values that can go in the extensible state component+import Data.Maybe(fromJust)+import Data.HashMap.Strict as M+import Data.Monoid+import Data.ConcreteTypeRep+import Data.Binary+import Data.Typeable(cast)+import Data.ByteString.Lazy(ByteString)+import Data.IORef+import System.IO.Unsafe(unsafePerformIO)+import qualified Data.Dynamic as D++--------------------------------- Nonserializable dynamics+-- | Class of values that can go in a 'ConfigDynamic' or a 'ConfigDynamicValues'.+-- These will typically go in a 'Config'. As the 'Config' has no mutable state,+-- there is no need to serialize these values: if needed, they will be set in the+-- user's configuration file. The 'Initializable' constraint ensures that, even if+-- the user hasn't customised this config variable, a value is stil available.+class (Initializable a, Typeable a) => YiConfigVariable a++-- | An \"extensible record\" of 'YiConfigVariable's. Can be constructed and accessed with 'initial' and 'configVariableA'. --+-- This type can be thought of as a record containing /all/ 'YiConfigVariable's in existence.+newtype ConfigVariables = CV (M.HashMap ConcreteTypeRep D.Dynamic)+ deriving(Monoid) +instance Initializable ConfigVariables where initial = mempty --- | The default value. If a function tries to get a copy of the state, but the state--- hasn't yet been created, 'initial' will be called to supply *some* value. The value--- of initial will probably be something like Nothing, \[\], \"\", or 'Data.Sequence.empty' - compare --- the 'mempty' of "Data.Monoid".-class (Typeable a) => Initializable a where- initial :: a+-- | Accessor for any 'YiConfigVariable'. Neither reader nor writer can fail:+-- if the user's config file hasn't set a value for a 'YiConfigVariable',+-- then the default value is used.+configVariableA :: forall a. YiConfigVariable a => Accessor ConfigVariables a+configVariableA = accessor getCV setCV+ where+ setCV v (CV m) = CV (M.insert (cTypeOf (undefined :: a)) (D.toDyn v) m)+ getCV (CV m) = + case M.lookup (cTypeOf (undefined :: a)) m of+ Nothing -> initial+ Just x -> fromJust $ D.fromDynamic x --- Unfortunately, this is not serializable: there is no way to recover a type from a TypeRep.-data Dynamic = forall a. Initializable a => Dynamic a+-- | Class of values that can go in a 'Dynamic' or a 'DynamicValues'. These are+-- typically for storing custom state in a 'FBuffer' or an 'Editor'.+class (Initializable a, Binary a, Typeable a) => YiVariable a --- | An extensible record, indexed by type-type DynamicValues = M.Map String Dynamic+--------------------------- Serializable dynamics+{-+[Serialization and the use of unsafePerformIO]+To implement deserialization, we store the value as a ByteString (i.e. in its+serialized form) until someone tries to read from the Dynamic (at which time we+have access to the deserializer). To avoid having to repeatedly deserialize when+reading, we cheat (unsafePerformIO) and cache the deserialized value. -toDyn :: Initializable a => a -> Dynamic-toDyn = Dynamic+A pure implementation would be possible if we omitted this caching, which gives+at least some justification for the impurity.+-} -fromDynamic :: forall a. Typeable a => Dynamic -> Maybe a-fromDynamic (Dynamic b) = if typeOf (undefined :: a) == typeOf b then Just (unsafeCoerce# b) else Nothing+{-+Currently, we don't export 'Dynamic' as there are no users of it in Yi. It is +hard to see where a 'Dynamic' would be preferable to a 'DynamicValues'.+-} -instance (Typeable a) => Initializable (Maybe a) where- initial = Nothing+-- | Serializable, initializable dynamically-typed values.+newtype Dynamic = D (IORef DynamicHelper)+ deriving(Typeable) --- | Accessor for a dynamic component-dynamicValueA :: Initializable a => Accessor DynamicValues a+data DynamicHelper+ = forall a. YiVariable a => Dynamic !a+ | Serial !ConcreteTypeRep !ByteString++-- | Build a 'Dynamic'+toDyn :: YiVariable a => a -> Dynamic+toDyn a = D (unsafePerformIO (newIORef $! Dynamic a))++-- | Try to extract a value from the 'Dynamic'.+fromDynamic :: forall a. YiVariable a => Dynamic -> Maybe a+fromDynamic (D r) = unsafePerformIO (readIORef r >>= f) where+ f (Dynamic b) = return $ cast b+ f (Serial tr bs) = + if cTypeOf (undefined :: a) == tr + then do+ let b = decode bs+ writeIORef r (Dynamic b)+ return (Just b)+ else return Nothing++-- | Converts a dynamic to a serializable value+toSerialRep :: Dynamic -> (ConcreteTypeRep, ByteString)+toSerialRep (D r) = + case unsafePerformIO (readIORef r) of+ Dynamic a -> (cTypeOf a, encode a)+ Serial ctr bs -> (ctr, bs)++-- | Converts a serializable value to a dynamic.+fromSerialRep :: (ConcreteTypeRep, ByteString) -> Dynamic+fromSerialRep (ctr, bs) = D (unsafePerformIO (newIORef (Serial ctr bs)))++instance Binary Dynamic where+ put = put . toSerialRep+ get = fromSerialRep <$> get++---------------------- Dynamic records+-- | An extensible record, indexed by type.+newtype DynamicValues = DV (M.HashMap ConcreteTypeRep Dynamic)+ deriving(Typeable, Monoid)++-- | Accessor for a dynamic component. If the component is not found, the value 'initial' is used.+dynamicValueA :: forall a. YiVariable a => Accessor DynamicValues a dynamicValueA = accessor getDynamicValue setDynamicValue where- setDynamicValue :: forall a. Initializable a => a -> DynamicValues -> DynamicValues- setDynamicValue v = M.insert (show $ typeOf (undefined::a)) (toDyn v)+ setDynamicValue :: a -> DynamicValues -> DynamicValues+ setDynamicValue v (DV dv) = DV (M.insert (cTypeOf (undefined :: a)) (toDyn v) dv) - getDynamicValue :: forall a. Initializable a => DynamicValues -> a- getDynamicValue dv = case M.lookup (show $ typeOf (undefined::a)) dv of- Nothing -> initial- Just x -> fromJust $ fromDynamic x+ getDynamicValue :: DynamicValues -> a+ getDynamicValue (DV dv) = case M.lookup (cTypeOf (undefined::a)) dv of+ Nothing -> initial+ Just x -> fromJust $ fromDynamic x --- | The empty record-emptyDV :: DynamicValues-emptyDV = M.empty+instance Binary DynamicValues where+ put (DV dv) = put dv+ get = DV <$> get++instance Initializable DynamicValues where initial = mempty+++{-+TODO: since a 'DynamicValues' is now serialisable, it could potentially+exist for a long time (days/months?). No operations are provided to remove+entries from a 'DynamicValues'. If these start accumulating a lot of junk,+it may be necessary to prune them (perhaps keep track of access date for+'YiVariable's and remove the ones more than a month old?).+-}
src/library/Yi/Editor.hs view
@@ -12,6 +12,7 @@ import Data.Accessor.Basic (fromSetGet) import Data.Accessor.Template import Data.Binary+import Data.DeriveTH import Data.Either (rights) import Data.List (nub, delete, (\\), (!!), intercalate, take, drop, cycle) import Data.Maybe@@ -24,8 +25,10 @@ import Yi.Event (Event) import Yi.Interact as I import Yi.KillRing+import Yi.Layout import Yi.Prelude import Yi.Style (StyleName, defaultStyle)+import Yi.Tab import Yi.Window import qualified Data.Rope as R import qualified Data.DelayList as DelayList@@ -43,11 +46,11 @@ -- Invariant: never empty -- Invariant: first buffer is the current one. ,buffers :: !(M.Map BufferRef FBuffer)- ,refSupply :: !Int -- ^ Supply for buffer and window ids.+ ,refSupply :: !Int -- ^ Supply for buffer, window and tab ids. - ,tabs_ :: !(PL.PointedList (PL.PointedList Window)) -- ^ current tab contains the visible windows pointed list.+ ,tabs_ :: !(PL.PointedList Tab) -- ^ current tab contains the visible windows pointed list. - ,dynamic :: !(DynamicValues) -- ^ dynamic components+ ,dynamic :: !DynamicValues -- ^ dynamic components ,statusLines :: !Statuses ,maxStatusHeight :: !Int@@ -60,18 +63,20 @@ deriving Typeable instance Binary Editor where- put (Editor bss bs supply ts _dv _sl msh kr _re _dir _ev _cwa ) = put bss >> put bs >> put supply >> put ts >> put msh >> put kr+ put (Editor bss bs supply ts dv _sl msh kr _re _dir _ev _cwa ) = put bss >> put bs >> put supply >> put ts >> put dv >> put msh >> put kr get = do bss <- get bs <- get supply <- get ts <- get+ dv <- get msh <- get kr <- get return $ emptyEditor {bufferStack = bss, buffers = bs, refSupply = supply, tabs_ = ts,+ dynamic = dv, maxStatusHeight = msh, killring = kr }@@ -103,12 +108,12 @@ emptyEditor :: Editor emptyEditor = Editor { buffers = M.singleton (bkey buf) buf- ,tabs_ = PL.singleton (PL.singleton win)+ ,tabs_ = PL.singleton tab ,bufferStack = [bkey buf]- ,refSupply = 2+ ,refSupply = 3 ,currentRegex = Nothing ,searchDirection = Forward- ,dynamic = M.empty+ ,dynamic = initial ,statusLines = DelayList.insert (maxBound, ([""], defaultStyle)) [] ,killring = krEmpty ,pendingEvents = []@@ -116,7 +121,8 @@ ,onCloseActions = M.empty } where buf = newB 0 (Left "console") (R.fromString "")- win = (dummyWindow (bkey buf)) {wkey = 1, isMini = False}+ win = (dummyWindow (bkey buf)) {wkey = WindowRef 1, isMini = False}+ tab = makeTab1 2 win -- --------------------------------------------------------------------- @@ -126,17 +132,19 @@ $(nameDeriveAccessors ''Editor (\n -> Just (n ++ "A"))) --- TODO: replace this by accessor windows :: Editor -> PL.PointedList Window-windows editor = PL.focus $ tabs_ editor+windows e = e ^. windowsA windowsA :: Accessor Editor (PL.PointedList Window)-windowsA = PL.focusA . tabsA+windowsA = tabWindowsA . currentTabA -tabsA :: Accessor Editor (PL.PointedList (PL.PointedList Window))+tabsA :: Accessor Editor (PL.PointedList Tab) tabsA = tabs_A . fixCurrentBufferA_ -dynA :: Initializable a => Accessor Editor a+currentTabA :: Accessor Editor Tab+currentTabA = PL.focusA . tabsA++dynA :: YiVariable a => Accessor Editor a dynA = dynamicValueA . dynamicA -- ---------------------------------------------------------------------@@ -176,8 +184,8 @@ forceFold1 :: (Foldable t) => t a -> t a forceFold1 x = foldr seq x x -forceFold2 :: (Foldable t1, Foldable t2) => t1 (t2 a) -> t1 (t2 a)-forceFold2 x = foldr (seq . forceFold1) x x+forceFoldTabs :: Foldable t => t Tab -> t Tab+forceFoldTabs x = foldr (seq . forceTab) x x -- | Delete a buffer (and release resources associated with it). deleteBuffer :: BufferRef -> EditorM ()@@ -209,7 +217,7 @@ switchToBufferE nextB modify $ \e -> e {bufferStack = forceFold1 $ filter (k /=) $ bufferStack e, buffers = M.delete k (buffers e),- tabs_ = forceFold2 $ fmap (fmap pickOther) (tabs_ e)+ tabs_ = forceFoldTabs $ fmap (mapWindows pickOther) (tabs_ e) -- all windows open on that buffer must switch to another buffer. } modA windowsA (fmap (\w -> w { bufAccessList = forceFold1 . filter (k/=) $ bufAccessList w }))@@ -376,11 +384,11 @@ -- -- | Retrieve a value from the extensible state-getDynamic :: Initializable a => EditorM a+getDynamic :: YiVariable a => EditorM a getDynamic = getA (dynamicValueA . dynamicA) -- | Insert a value into the extensible state, keyed by its type-setDynamic :: Initializable a => a -> EditorM ()+setDynamic :: YiVariable a => a -> EditorM () setDynamic x = putA (dynamicValueA . dynamicA) x -- | Attach the next buffer in the buffer stack to the current window.@@ -431,9 +439,6 @@ , tmp_name_index :: Int } deriving Typeable -instance Initializable TempBufferNameHint where- initial = TempBufferNameHint "tmp" 0- instance Show TempBufferNameHint where show (TempBufferNameHint s i) = s ++ "-" ++ show i @@ -450,7 +455,7 @@ -- | Create a new window onto the given buffer. newWindowE :: Bool -> BufferRef -> EditorM Window-newWindowE mini bk = newZeroSizeWindow mini bk <$> newRef+newWindowE mini bk = newZeroSizeWindow mini bk . WindowRef <$> newRef -- | Attach the specified buffer to the current window switchToBufferE :: BufferRef -> EditorM ()@@ -499,6 +504,26 @@ prevWinE :: EditorM () prevWinE = modA windowsA PL.previous +-- | Swaps the focused window with the first window. Useful for layouts such as 'HPairOneStack', for which the first window is the largest.+swapWinWithFirstE :: EditorM ()+swapWinWithFirstE = modA windowsA (swapFocus (fromJust . PL.move 0))++-- | Moves the focused window to the first window, and moves all other windows down the stack.+pushWinToFirstE :: EditorM ()+pushWinToFirstE = modA windowsA pushToFirst+ where+ pushToFirst ws = case PL.delete ws of+ Nothing -> ws+ Just ws' -> PL.insertLeft (ws ^. PL.focusA) (fromJust $ PL.move 0 ws')++-- | Swap focused window with the next one+moveWinNextE :: EditorM ()+moveWinNextE = modA windowsA (swapFocus PL.next)++-- | Swap focused window with the previous one+moveWinPrevE :: EditorM ()+moveWinPrevE = modA windowsA (swapFocus PL.previous)+ -- | A "fake" accessor that fixes the current buffer after a change of the current -- window. -- Enforces invariant that top of buffer stack is the buffer of the current window.@@ -516,7 +541,7 @@ fixCurrentWindow :: EditorM () fixCurrentWindow = do b <- gets currentBuffer- modA (PL.focusA . PL.focusA . tabs_A) (\w -> w {bufkey = b})+ modA (PL.focusA . windowsA) (\w -> w {bufkey = b}) withWindowE :: Window -> BufferM a -> EditorM a withWindowE w = withGivenBufferAndWindow0 w (bufkey w)@@ -529,7 +554,7 @@ windowsOnBufferE :: BufferRef -> EditorM [Window] windowsOnBufferE k = do ts <- getA tabsA- return $ concatMap (concatMap (\win -> if (bufkey win == k) then [win] else [])) ts+ return $ concatMap (concatMap (\win -> if (bufkey win == k) then [win] else []) . (^. tabWindowsA)) ts -- | bring the editor focus the window with the given key. --@@ -544,7 +569,7 @@ check r@(True, _) _win = r searchWindowSet (False, tabIndex, _) ws = - case foldl check (False, 0) ws of+ case foldl check (False, 0) (ws ^. tabWindowsA) of (True, winIndex) -> (True, tabIndex, winIndex) (False, _) -> (False, tabIndex + 1, 0) searchWindowSet r@(True, _, _) _ws = r@@ -563,6 +588,33 @@ w <- newWindowE False b modA windowsA (PL.insertRight w) +-- | Cycle to the next layout manager, or the first one if the current one is nonstandard.+layoutManagersNextE :: EditorM ()+layoutManagersNextE = withLMStack PL.next++-- | Cycle to the previous layout manager, or the first one if the current one is nonstandard.+layoutManagersPreviousE :: EditorM ()+layoutManagersPreviousE = withLMStack PL.previous++-- | Helper function for 'layoutManagersNext' and 'layoutManagersPrevious'+withLMStack :: (PL.PointedList AnyLayoutManager -> PL.PointedList AnyLayoutManager) -> EditorM ()+withLMStack f = askCfg >>= \cfg -> modA (tabLayoutManagerA . currentTabA) (go (layoutManagers cfg))+ where+ go [] lm = lm+ go lms lm =+ case findPL (layoutManagerSameType lm) lms of+ Nothing -> head lms+ Just lmsPL -> f lmsPL ^. PL.focusA++-- | Next variant of the current layout manager, as given by 'nextVariant'+layoutManagerNextVariantE :: EditorM ()+layoutManagerNextVariantE = modA (tabLayoutManagerA . currentTabA) nextVariant++-- | Previous variant of the current layout manager, as given by 'previousVariant'+layoutManagerPreviousVariantE :: EditorM ()+layoutManagerPreviousVariantE = modA (tabLayoutManagerA . currentTabA) previousVariant++ -- | Enlarge the current window enlargeWinE :: EditorM () enlargeWinE = error "enlargeWinE: not implemented"@@ -571,12 +623,17 @@ shrinkWinE :: EditorM () shrinkWinE = error "shrinkWinE: not implemented" +-- | Sets the given divider position on the current tab+setDividerPosE :: DividerRef -> DividerPosition -> EditorM ()+setDividerPosE ref pos = putA (tabDividerPositionA ref . currentTabA) pos+ -- | Creates a new tab containing a window that views the current buffer. newTabE :: EditorM () newTabE = do bk <- gets currentBuffer win <- newWindowE False bk- modA tabsA (PL.insertRight (PL.singleton win))+ ref <- newRef+ modA tabsA (PL.insertRight (makeTab1 ref win)) -- | Moves to the next tab in the round robin set of tabs nextTabE :: EditorM ()@@ -658,3 +715,15 @@ onCloseBufferE b a = do modA onCloseActionsA $ M.insertWith' (\_ old_a -> old_a >> a) b a +-- put the template haskell at the end, to avoid 'variable not found' compile errors+$(derive makeBinary ''TempBufferNameHint)++-- For GHC 7.0 with template-haskell 2.5 (at least on my computer - coconnor) the Binary instance+-- needs to be defined before the YiVariable instance. +--+-- GHC 7.1 does not appear to have this issue.+instance Initializable TempBufferNameHint where+ initial = TempBufferNameHint "tmp" 0++instance YiVariable TempBufferNameHint+
src/library/Yi/Eval.hs view
@@ -1,77 +1,169 @@-{-# LANGUAGE CPP, ScopedTypeVariables, TypeOperators, DeriveDataTypeable #-}+{-# LANGUAGE CPP, ScopedTypeVariables, TypeOperators, DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell, RecordWildCards #-} module Yi.Eval (+ -- * Main (generic) evaluation interface+ execEditorAction,+ getAllNamesInScope,+ Evaluator(..),+ evaluator,+ -- ** Standard evaluators+ ghciEvaluator,+ publishedActionsEvaluator,+ publishedActions,+ publishAction, -- * Eval\/Interpretation jumpToErrorE, jumpToE, consoleKeymap,- execEditorAction,- getAllNamesInScope ) where +import Data.Accessor.Template import Data.Array import Data.List+import Data.Monoid import Prelude hiding (error, (.)) import qualified Language.Haskell.Interpreter as LHI import System.FilePath import System.Directory+import qualified Data.HashMap.Strict as M -import Yi.Core hiding (toDyn, concatMap)-import Yi.Dired+import Yi.Config.Simple.Types+import Yi.Core hiding (concatMap) import Yi.File+import Yi.Hooks import Yi.Regex --- | Returns an Interpreter action that loads the desired modules and interprets the expression.+-- | Runs the action, as written by the user.+--+-- The behaviour of this function can be customised by modifying the 'Evaluator' variable. execEditorAction :: String -> YiM ()-execEditorAction s = do- contextPath <- (</> ".yi" </> "local") <$> io getHomeDirectory- let contextFile = contextPath </> "Env.hs"- haveUserContext <- io $ doesFileExist contextFile- res <- io $ LHI.runInterpreter $ do- LHI.set [LHI.searchPath LHI.:= []]- LHI.set [LHI.languageExtensions LHI.:= [LHI.OverloadedStrings, - LHI.NoImplicitPrelude -- use Yi prelude instead.- ]]- when haveUserContext $ do- LHI.loadModules [contextFile]- LHI.setTopLevelModules ["Env"]+execEditorAction = runHook execEditorActionImpl - LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")] -- Yi.Keymap: Action lives there- LHI.interpret ("Yi.makeAction ("++s++")") (error "as" :: Action)- case res of- Left err -> errorEditor (show err)- Right action -> runAction action+-- | Lists the action names in scope, for use by 'execEditorAction'.+--+-- The behaviour of this function can be customised by modifying the 'Evaluator' variable.+getAllNamesInScope :: YiM [String]+getAllNamesInScope = runHook getAllNamesInScopeImpl -data NamesCache = NamesCache [String] deriving Typeable+{- | Config variable for customising the behaviour of 'execEditorAction' and 'getAllNamesInScope'. ++Set this variable using 'evaluator'. See 'ghciEvaluator' and 'finiteListEvaluator' for two implementation.+-}+data Evaluator = Evaluator {+ execEditorActionImpl :: String -> YiM (), -- ^ implementation of 'execEditorAction'+ getAllNamesInScopeImpl :: YiM [String] -- ^ implementation of 'getAllNamesInScope'+ }+ deriving(Typeable)++-- | The evaluator to use for 'execEditorAction' and 'getAllNamesInScope'.+evaluator :: Field Evaluator+evaluator = customVariable++instance Initializable Evaluator where initial = ghciEvaluator+instance YiConfigVariable Evaluator++------------------------- Evaluator based on GHCi+newtype NamesCache = NamesCache [String] deriving (Typeable, Binary) instance Initializable NamesCache where initial = NamesCache []+instance YiVariable NamesCache -getAllNamesInScope :: YiM [String]-getAllNamesInScope = do - NamesCache cache <- withEditor $ getA dynA- result <-if null cache then do- res <-io $ LHI.runInterpreter $ do- LHI.set [LHI.searchPath LHI.:= []]- LHI.getModuleExports "Yi"- return $ case res of- Left err ->[show err]- Right exports -> flattenExports exports- else return $ sort cache- withEditor $ putA dynA (NamesCache result)- return result+{- | Evaluator implemented by calling GHCi. This evaluator can run arbitrary expressions in the class 'YiAction'.++The following two imports are always present:++> import Yi+> import qualified Yi.Keymap as Yi.Keymap++Also, if the file ++> $HOME/.yi/local/Env.hs++exists, it is imported unqualified.+-}+ghciEvaluator :: Evaluator+ghciEvaluator = Evaluator{..} where+ execEditorActionImpl :: String -> YiM ()+ execEditorActionImpl s = do+ contextPath <- (</> ".yi" </> "local") <$> io getHomeDirectory+ let contextFile = contextPath </> "Env.hs"+ haveUserContext <- io $ doesFileExist contextFile+ res <- io $ LHI.runInterpreter $ do+ LHI.set [LHI.searchPath LHI.:= []]+ LHI.set [LHI.languageExtensions LHI.:= [LHI.OverloadedStrings, + LHI.NoImplicitPrelude -- use Yi prelude instead.+ ]]+ when haveUserContext $ do+ LHI.loadModules [contextFile]+ LHI.setTopLevelModules ["Env"]++ LHI.setImportsQ [("Yi", Nothing), ("Yi.Keymap",Just "Yi.Keymap")] -- Yi.Keymap: Action lives there+ LHI.interpret ("Yi.makeAction ("++s++")") (error "as" :: Action)+ case res of+ Left err -> errorEditor (show err)+ Right action -> runAction action++ getAllNamesInScopeImpl :: YiM [String]+ getAllNamesInScopeImpl = do + NamesCache cache <- withEditor $ getA dynA+ result <-if null cache then do+ res <-io $ LHI.runInterpreter $ do+ LHI.set [LHI.searchPath LHI.:= []]+ LHI.getModuleExports "Yi"+ return $ case res of+ Left err ->[show err]+ Right exports -> flattenExports exports+ else return $ sort cache+ withEditor $ putA dynA (NamesCache result)+ return result -flattenExports :: [LHI.ModuleElem] -> [String]-flattenExports = concatMap flattenExport+ flattenExports :: [LHI.ModuleElem] -> [String]+ flattenExports = concatMap flattenExport -flattenExport :: LHI.ModuleElem -> [String]-flattenExport (LHI.Fun x) = [x]-flattenExport (LHI.Class _ xs) = xs-flattenExport (LHI.Data _ xs) = xs+ flattenExport :: LHI.ModuleElem -> [String]+ flattenExport (LHI.Fun x) = [x]+ flattenExport (LHI.Class _ xs) = xs+ flattenExport (LHI.Data _ xs) = xs +------------------- PublishedActions evaluator+newtype PublishedActions = PublishedActions { publishedActions_ :: M.HashMap String Action }+ deriving(Typeable, Monoid)+$(nameDeriveAccessors ''PublishedActions (\n -> (Just $ n ++ "A")))+instance Initializable PublishedActions where initial = mempty+instance YiConfigVariable PublishedActions++-- | Accessor for the published actions. Consider using 'publishAction'.+publishedActions :: Field (M.HashMap String Action)+publishedActions = publishedActions_A . customVariable++-- | Publish the given action, by the given name. This will overwrite any existing actions by the same name.+publishAction :: (YiAction a x, Show x) => String -> a -> ConfigM ()+publishAction s a = modA publishedActions (M.insert s (makeAction a))++{- | Evaluator based on a fixed list of published actions. Has a few differences from 'ghciEvaluator':++ * expressions can't be evaluated++ * all suggested actions are actually valued++ * (related to the above) doesn't contain junk actions from Prelude++ * doesn't require GHCi backend, so uses less memory+-}+publishedActionsEvaluator :: Evaluator+publishedActionsEvaluator = Evaluator{..} where+ getAllNamesInScopeImpl = (M.keys . (^. publishedActions)) <$> askCfg+ execEditorActionImpl s = + ((M.lookup s . (^. publishedActions)) <$> askCfg) >>=+ maybe (return ()) runAction+++------------------- Miscellaneous interpreter+ jumpToE :: String -> Int -> Int -> YiM () jumpToE filename line column = do- editFile filename+ discard $ editFile filename withBuffer $ do _ <- gotoLn line moveXorEol column
src/library/Yi/Event.hs view
@@ -14,7 +14,7 @@ import Yi.Prelude import Prelude () -data Modifier = MShift | MCtrl | MMeta | MSuper+data Modifier = MShift | MCtrl | MMeta | MSuper | MHyper deriving (Show,Eq,Ord) data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
src/library/Yi/File.hs view
@@ -21,14 +21,11 @@ import Data.Maybe import Data.Time import Control.Monad.Trans-import Control.Monad.State (gets) import System.Directory-import System.IO.UTF8 as UTF8 import System.FilePath import System.FriendlyPath import qualified Data.Rope as R -import Yi.Buffer (file) import Yi.Config import Yi.Core import Yi.Dired@@ -100,7 +97,7 @@ case mfp of Just fp -> do now <- io getCurrentTime- s <- liftIO $ UTF8.readFile fp+ s <- liftIO $ R.readFile fp withBuffer $ revertB s now msgEditor ("Reverted from " ++ show fp) Nothing -> do@@ -145,9 +142,9 @@ fwriteBufferE bufferKey = do nameContents <- withGivenBuffer bufferKey ((,) <$> gets file <*> streamB Forward 0) case nameContents of- (Just f, contents) -> do now <- io getCurrentTime+ (Just f, contents) -> do liftIO $ R.writeFile f contents+ now <- io getCurrentTime withGivenBuffer bufferKey (markSavedB now)- liftIO $ R.writeFile f contents (Nothing, _c) -> msgEditor "Buffer not associated with a file" -- | Write current buffer to disk as @f@. The file is also set to @f@
src/library/Yi/History.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, TemplateHaskell, FlexibleInstances #-} -- Copyright (c) 2005,2007,2008 Jean-Philippe Bernardy @@ -7,6 +7,8 @@ module Yi.History where import Yi.Buffer+import Data.Binary+import Data.DeriveTH import Data.List import Data.Accessor.Container import Yi.Dynamic@@ -26,6 +28,9 @@ deriving (Show, Typeable) instance Initializable History where initial = (History (-1) [] "")+$(derive makeBinary ''History)++instance YiVariable (M.Map String History) dynKeyA :: (Initializable v, Ord k) => k -> Accessor (M.Map k v) v dynKeyA = mapDefault initial
src/library/Yi/Hoogle.hs view
@@ -10,7 +10,6 @@ import Yi.Core import Yi.Process (runProgCommand)-import Yi.Buffer (replaceRegionB, unitWord) -- | Remove anything starting with uppercase letter. These denote either module names or types. caseSensitize :: [String] -> [String]
+ src/library/Yi/Hooks.hs view
@@ -0,0 +1,92 @@+{- | This module provides assistance in implementing \"hooks\" in Yi. This module provides no major new functionality -- only assistance in using 'YiConfigVariable's more easily to implement hooks.++We consider a simple example. Suppose we have a function++> promptForFile :: Maybe FilePath -> YiM FilePath++which prompts the user to select a file from their file system, starting with the provided directory (if actually provided).+Since this is a frequent task in Yi, it is important for it to be as user-friendly as possible. If opinions vary on the+meaning of \"user-friendly\", then we would really like to provide multiple implementations of @promptForFile@, and allow+users to select which implementation to use in their config files.++A way to achieve this is using hooks, as follows:++> -- create a new type+> newtype FilePrompter = FilePrompter { runFilePrompter :: Maybe FilePath -> YiM FilePath }+> deriving(Typeable)+> $(nameDeriveAccessors ''FilePrompter (n -> Just (n ++ "A")))+>+> -- give some implementations+> filePrompter1, filePrompter2, filePrompter3 :: FilePrompter+> ...+>+> -- declare FilePrompter as a YiConfigVariable (so it can go in the Config)+> instance YiConfigVariable FilePrompter+>+> -- specify the default FilePrompter+> instance Initializable FilePrompter where+> initial = filePrompter1+>+> -- replace the old promptForFile function with a shim+> promptForFile :: Maybe FilePath -> YiM FilePath+> promptForFile = runHook runFilePrompter+>+> -- provide a custom-named Field for Yi.Config.Simple (not strictly necessary, but user-friendly)+> filePrompter :: Field FilePrompter+> filePrompter = customVariable++The user can write++> ...+> filePrompter %= filePrompter2+> ...++in their config file, and calls to @promptForFile@ will now use the different prompter. Library code which+called @promptForFile@ does not need to be changed, but it gets the new @filePrompter2@ behaviour automatically.++See "Yi.Eval" for a real example of hooks.+-}+module Yi.Hooks(+ -- * Convenience function 'runHook'+ runHook,+ HookType,+ -- * Re-exports from "Yi.Config.Simple"+ customVariable,+ Field,+ )+ where++import Prelude()+import Yi.Config+import Yi.Prelude+import Yi.Dynamic+import Yi.Editor+import Yi.Keymap+import Yi.Config.Simple.Types(customVariable, Field)++{- | +Looks up the configured value for the hook, and runs it. The argument to 'runHook' will typically be a record accessor. See 'HookType' for the valid hook types.+-}+runHook :: (HookType ty, YiConfigVariable var) => (var -> ty) -> ty+runHook = runHookImpl++{- | The class of \"valid hooks\". This class is exported abstractly, but the instances can be phrased quite simply: the functions (of arbitrarily many arguments, including zero) which run in either the 'EditorM' or 'YiM' monads.++A typical example would be something like ++@Int -> String -> 'EditorM' String@.++-}+class HookType ty where+ runHookImpl :: YiConfigVariable var => (var -> ty) -> ty++instance HookType (EditorM a) where+ runHookImpl lookupHook = do+ cfg <- askCfg+ lookupHook (cfg ^. configVarsA ^. configVariableA)+instance HookType (YiM a) where+ runHookImpl lookupHook = do+ cfg <- askCfg+ lookupHook (cfg ^. configVarsA ^. configVariableA)+instance HookType b => HookType (a -> b) where+ runHookImpl lookupHook a = runHookImpl (($a) . lookupHook)
src/library/Yi/IReader.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} -- | This module defines a list type and operations on it; it further -- provides functions which write in and out the list. -- The goal is to make it easy for the user to store a large number of text buffers@@ -7,7 +7,7 @@ module Yi.IReader where import Control.Monad.State (join)-import Data.Binary (decode, encodeFile)+import Data.Binary (Binary, decode, encodeFile) import Data.Sequence as S import Data.Typeable (Typeable) import System.Directory (getHomeDirectory)@@ -18,21 +18,23 @@ import Yi.Buffer.Misc (bufferDynamicValueA, BufferM) import Yi.Buffer.Normal (regionOfB, TextUnit(Document)) import Yi.Buffer.Region (readRegionB)-import Yi.Dynamic (Initializable(initial))+import Yi.Dynamic import Yi.Keymap (withBuffer, YiM)-import Yi.Prelude (getA, putA, io, discard)+import Yi.Prelude (getA, putA, io, discard, Initializable(..)) type Article = B.ByteString-type ArticleDB = Seq Article+newtype ArticleDB = ADB { unADB :: Seq Article }+ deriving(Typeable, Binary) -instance (Typeable a) => Initializable (Seq a) where- initial = S.empty+instance Initializable ArticleDB where+ initial = ADB S.empty+instance YiVariable ArticleDB -- | Take an 'ArticleDB', and return the first 'Article' and an ArticleDB - *without* that article. split :: ArticleDB -> (Article, ArticleDB)-split adb = case viewl adb of- EmptyL -> (B.pack "", S.empty)- (a :< b) -> (a, b)+split (ADB adb) = case viewl adb of+ EmptyL -> (B.pack "", initial)+ (a :< b) -> (a, ADB b) -- | 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 - every article gets equal time.@@ -42,21 +44,21 @@ -- | We remove the old first article, and we stick it on the end of the -- list using the presumably modified version. removeSetLast :: ArticleDB -> Article -> ArticleDB-removeSetLast adb old = snd (split adb) |> old+removeSetLast adb old = ADB (unADB (snd (split adb)) |> old) -- we move the last entry to the entry 'length `div` n'from the beginning; so 'shift 1' would do nothing -- (eg. the last index is 50, 50 `div` 1 == 50, so the item would be moved to where it is) -- 'shift 2' will move it to the middle of the list, though; last index = 50, then 50 `div` 2 will shift -- the item to index 25, and so on down to 50 `div` 50 - the head of the list/Seq. shift :: Int ->ArticleDB -> ArticleDB-shift n adb = if n < 2 || lst < 2 then adb else (r |> lastentry) >< s'- where lst = S.length adb - 1- (r,s) = S.splitAt (lst `div` n) adb+shift n adb = if n < 2 || lst < 2 then adb else ADB $ (r |> lastentry) >< s'+ where lst = S.length (unADB adb) - 1+ (r,s) = S.splitAt (lst `div` n) (unADB adb) (s' :> lastentry) = S.viewr s -- | Insert a new article with top priority (that is, at the front of the list). insertArticle :: ArticleDB -> Article -> ArticleDB-insertArticle adb new = new <| adb+insertArticle (ADB adb) new = ADB (new <| adb) -- | Serialize given 'ArticleDB' out. writeDB :: ArticleDB -> YiM ()@@ -64,7 +66,7 @@ -- | Read in database from 'dbLocation' and then parse it into an 'ArticleDB'. readDB :: YiM ArticleDB-readDB = io $ (dbLocation >>= r) `catch` (\_ -> return empty)+readDB = io $ (dbLocation >>= r) `catch` (\_ -> return initial) where r = fmap (decode . BL.fromChunks . return) . B.readFile -- We read in with strict bytestrings to guarantee the file is closed, -- and then we convert it to the lazy bytestring data.binary expects.@@ -81,7 +83,7 @@ oldDbNewArticle :: YiM (ArticleDB, Article) oldDbNewArticle = do saveddb <- withBuffer $ getA bufferDynamicValueA newarticle <-fmap B.pack $ withBuffer getBufferContents- if not $ S.null saveddb+ if not $ S.null (unADB saveddb) then return (saveddb, newarticle) else do olddb <- readDB return (olddb, newarticle)@@ -110,7 +112,7 @@ -- | Delete current article (the article as in the database), and go to next one. deleteAndNextArticle :: YiM () deleteAndNextArticle = do (oldb,_) <- oldDbNewArticle -- throw away changes,- let ndb = case viewl oldb of -- drop 1st article+ let ndb = ADB $ case viewl (unADB oldb) of -- drop 1st article EmptyL -> empty (_ :< b) -> b writeDB ndb
src/library/Yi/IncrementalParse.hs view
@@ -1,5 +1,6 @@ -- Copyright (c) JP Bernardy 2008-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Yi.IncrementalParse (recoverWith, symbol, eof, lookNext, testNext, State, P, Parser(..), AlexState (..), scanner) where import Parser.Incremental hiding (run)
src/library/Yi/Keymap.hs view
@@ -22,7 +22,6 @@ import qualified Data.Map as M import qualified Yi.Editor as Editor import qualified Yi.Interact as I-import qualified Yi.UI.Common as UI import Data.Accessor.Template data Action = forall a. Show a => YiA (YiM a)@@ -91,6 +90,7 @@ write :: (I.MonadInteract m Action ev, YiAction a x, Show x) => a -> m () write x = I.write (makeAction x) +write' :: (I.MonadInteract m Action e, YiAction a x, Show x) => String -> a -> m () write' s x = I.write (TaggedA s (makeAction x)) --------------------------------
src/library/Yi/Keymap/Emacs.hs view
@@ -21,7 +21,6 @@ import Yi.Misc (adjBlock, adjIndent) import Yi.Rectangle import Yi.TextCompletion-import Yi.Keymap import Yi.Keymap.Emacs.KillRing import Yi.Mode.Buffers ( listBuffers ) import Yi.Keymap.Emacs.Utils@@ -50,7 +49,6 @@ import Data.Char import Control.Monad-import Control.Applicative data ModeMap = ModeMap { eKeymap :: Keymap , completionCaseSensitive :: Bool@@ -81,7 +79,7 @@ write (adjBlock n >> replicateM_ n (insertB c)) completionKm :: Bool -> Keymap-completionKm caseSensitive = do some ((meta (char '/') ?>>! wordComplete' caseSensitive))+completionKm caseSensitive = do discard $ some ((meta (char '/') ?>>! wordComplete' caseSensitive)) deprioritize write resetComplete -- 'adjustPriority' is there to lift the ambiguity between "continuing" completion@@ -159,6 +157,19 @@ -- All the keybindings of the form "C-M-c" where 'c' is some character , ( ctrl $ metaCh 'w') ?>>! appendNextKillE+ , ( ctrl $ metaCh ' ') ?>>! layoutManagersNextE+ , ( ctrl $ metaCh ',') ?>>! layoutManagerNextVariantE+ , ( ctrl $ metaCh '.') ?>>! layoutManagerPreviousVariantE+ , ( ctrl $ metaCh 'j') ?>>! nextWinE+ , ( ctrl $ metaCh 'k') ?>>! prevWinE+ , ( ctrl $ meta $ spec KEnter) ?>>! swapWinWithFirstE+++-- All the keybindings of the form "S-C-M-c" where 'c' is some key+ , ( shift $ ctrl $ metaCh 'j') ?>>! moveWinNextE+ , ( shift $ ctrl $ metaCh 'k') ?>>! moveWinPrevE+ , ( shift $ ctrl $ meta $ spec KEnter) ?>>! pushWinToFirstE+ , ( Event (KASCII ' ') [MShift,MCtrl,MMeta]) ?>>! layoutManagersPreviousE -- All the key-bindings which are preceded by a 'C-x' , ctrlCh 'x' ?>> ctrlX
src/library/Yi/Keymap/Emacs/KillRing.hs view
@@ -6,7 +6,6 @@ import Prelude () import Yi.Prelude -import Yi.Monad import Yi.Keymap import Yi.Buffer import Yi.Editor
src/library/Yi/Keymap/Emacs/Utils.hs view
@@ -54,7 +54,6 @@ import Control.Monad (filterM, replicateM_) import Yi.Command (cabalConfigureE, cabalBuildE, reloadProjectE) import Yi.Core-import Yi.Dired import Yi.Eval import Yi.File import Yi.MiniBuffer@@ -171,7 +170,7 @@ isearchKeymap :: Direction -> Keymap isearchKeymap dir = do write $ isearchInitE dir- many searchKeymap+ discard $ many searchKeymap choice [ ctrl (char 'g') ?>>! isearchCancelE , oneOf [ctrl (char 'm'), spec KEnter] >>! isearchFinishE ] @@ -193,7 +192,7 @@ Right re = makeSearchOptsM [] replaceWhat withEditor $ do setRegexE re- spawnMinibufferE+ discard $ spawnMinibufferE ("Replacing " ++ replaceWhat ++ " with " ++ replaceWith ++ " (y,n,q,!):") (const replaceKm) qrNext win b re@@ -203,7 +202,7 @@ evalRegionE :: YiM () evalRegionE = do- withBuffer (getSelectRegionB >>= readRegionB) >>= return -- FIXME: do something sensible.+ discard $ withBuffer (getSelectRegionB >>= readRegionB) >>= return -- FIXME: do something sensible. return () -- * Code for various commands@@ -338,8 +337,8 @@ case lookupTag tag tagTable of Nothing -> fail $ "No tags containing " ++ tag Just (filename, line) -> do- editFile filename- withBuffer $ gotoLn line+ discard $ editFile filename+ discard $ withBuffer $ gotoLn line return () -- | Call continuation @act@ with the TagTable. Uses the global table@@ -359,5 +358,8 @@ withEditor $ setTags tagTable act tagTable +{-+TODO: export or remove resetTagTable :: YiM () resetTagTable = withEditor resetTags+-}
src/library/Yi/Keymap/Keys.hs view
@@ -7,9 +7,9 @@ ( module Yi.Event, module Yi.Interact,- printableChar, charOf, shift, meta, ctrl, super, spec, char,+ printableChar, charOf, shift, meta, ctrl, super, hyper, spec, char, (>>!), (>>=!), (?>>), (?>>!), (?*>>), (?*>>!),- ctrlCh, metaCh,+ ctrlCh, metaCh, hyperCh, optMod, pString ) where@@ -38,7 +38,7 @@ do Event (KASCII c) _ <- eventBetween (modifier $ char l) (modifier $ char h) return c -shift,ctrl,meta,super :: Event -> Event+shift,ctrl,meta,super,hyper :: Event -> Event shift (Event (KASCII c) ms) | isAlpha c = Event (KASCII (toUpper c)) ms | otherwise = error "shift: unhandled event" shift (Event k ms) = Event k $ nub $ sort (MShift:ms)@@ -49,6 +49,8 @@ super (Event k ms) = Event k $ nub $ sort (MSuper:ms) +hyper (Event k ms) = Event k $ nub $ sort (MHyper:ms)+ char :: Char -> Event char '\t' = Event KTab [] char '\r' = Event KEnter []@@ -60,6 +62,9 @@ metaCh :: Char -> Event metaCh = meta . char++hyperCh :: Char -> Event+hyperCh = hyper . char -- | @optMod f ev@ produces a 'MonadInteract' that consumes @ev@ or @f ev@ optMod ::(MonadInteract m w Event) => (Event -> Event) -> Event -> m Event
src/library/Yi/Keymap/Vim.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE RelaxedPolyRec, FlexibleContexts, DeriveDataTypeable, TemplateHaskell, CPP, PatternGuards #-}+{-# LANGUAGE RelaxedPolyRec, FlexibleContexts, DeriveDataTypeable, TemplateHaskell, CPP, PatternGuards, GeneralizedNewtypeDeriving, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TH-derived accessors -- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2008 Nicolas Pouillard@@ -39,7 +40,9 @@ ) where import Prelude (maybe, length, filter, map, drop, break, uncurry, reads)+import Yi.Prelude +import Data.Binary import Data.Char import Data.List (nub, take, words, dropWhile, takeWhile, intersperse, reverse) import Data.Maybe (fromMaybe, isJust)@@ -132,8 +135,13 @@ | NoOp deriving (Typeable) +instance Binary ViCmd where+ put = dummyPut+ get = dummyGet+ instance Initializable ViCmd where initial = NoOp+instance YiVariable ViCmd data ViInsertion = ViIns { viActFirst :: Maybe (EditorM ()) -- ^ The action performed first , viActBefore :: BufferM () -- ^ The action performed before insertion@@ -143,7 +151,16 @@ } deriving (Typeable) +newtype MViInsertion = MVI { unMVI :: Maybe ViInsertion }+ deriving(Typeable, Initializable)++instance Binary MViInsertion where+ put = dummyPut+ get = dummyGet+instance YiVariable MViInsertion+ $(nameDeriveAccessors ''ViInsertion $ Just.(++ "A"))+$(nameDeriveAccessors ''MViInsertion $ Just.(++ "_A")) data VimOpts = VimOpts { tildeop :: Bool , completeCaseSensitive :: Bool@@ -158,11 +175,13 @@ type VimExCmdMap = [VimExCmd] -- very simple implementation yet newtype VimTagStack = VimTagStack { tagsStack :: [(FilePath, Point)] }- deriving (Typeable)+ deriving (Typeable, Binary) instance Initializable VimTagStack where initial = VimTagStack [] +instance YiVariable VimTagStack+ getTagStack :: EditorM VimTagStack getTagStack = getDynamic @@ -214,7 +233,7 @@ lastViCommandA = dynA currentViInsertionA :: Accessor FBuffer (Maybe ViInsertion)-currentViInsertionA = bufferDynamicValueA+currentViInsertionA = unMVI_A . bufferDynamicValueA applyViCmd :: Maybe Int -> ViCmd -> YiM () applyViCmd _ NoOp = return ()@@ -484,7 +503,7 @@ core_vis_mode selStyle = do write $ do withBuffer0' $ putA regionStyleA selStyle setStatus ([msg selStyle], defaultStyle)- many (vis_move <|>+ discard $ many (vis_move <|> select_any_unit (withBuffer0' . (\r -> resetSelectStyle >> extendSelectRegionB r >> leftB))) visual2other selStyle where msg LineWise = "-- VISUAL LINE --"@@ -536,7 +555,7 @@ [c ?>> return (Exclusive, a x) | (c,a) <- moveCmdFM_exclusive ] ++ [events evs >> return (Exclusive, a x) | (evs,a) <- moveCmdS_exclusive ] ++ [c ?>> return (LineWise, a x) | (c,a) <- moveUpDownCmdFM] ++- [do event c; c' <- textChar; return (r, a c' x) | (c,r,a) <- move2CmdFM] +++ [do discard $ event c; c' <- textChar; return (r, a c' x) | (c,r,a) <- move2CmdFM] ++ [char 'G' ?>> return (LineWise, ArbMove $ setMarkHere '\'' >> maybe (botB >> firstNonSpaceB) gotoFNS cnt) ,pString "gg" >> return (LineWise, ArbMove $ setMarkHere '\'' >> gotoFNS (fromMaybe 0 cnt)) ,char '\'' ?>> do c <- validMarkIdentifier@@ -686,7 +705,7 @@ when (enableTagStack $ v_opts self) viTagStackPushPos viFnewE filename- withBuffer' $ gotoLn line+ discard $ withBuffer' $ gotoLn line return () viTagStackPushPos :: YiM ()@@ -695,8 +714,8 @@ pushTagStack bn p gotoPrevTagMark :: Int -> YiM ()- gotoPrevTagMark count = do- lastP <- withEditor $ popTagStack count+ gotoPrevTagMark cnt = do+ lastP <- withEditor $ popTagStack cnt case lastP of Nothing -> withEditor $ fail "bottom of tag stack" Just (fp, p) -> do viFnewE fp@@ -1144,10 +1163,12 @@ if c == '0' then deleteB Character Backward >> deleteIndentOfRegion r else shiftIndentOfRegion (-1) r +{-+TODO: use or remove upTo :: Alternative f => f a -> Int -> f [a] _ `upTo` 0 = empty p `upTo` n = (:) <$> p <*> (p `upTo` pred n <|> pure []) -+-} insertSpecialChar :: (Char -> BufferM ()) -> VimMode insertSpecialChar insrepB = insertNumber insrepB@@ -1270,7 +1291,7 @@ ,ctrlCh 'u' ?>>! moveToSol >> deleteToEol] <|| (insertChar >>! setHistoryPrefix) actionAndHistoryPrefix act = do- withBuffer0 $ act+ discard $ withBuffer0 $ act setHistoryPrefix setHistoryPrefix = do ls <- withEditor . withBuffer0 $ elemsB@@ -1328,7 +1349,7 @@ historyStart historyPrefixSet ""- spawnMinibufferE prompt $ const ex_process+ discard $ spawnMinibufferE prompt $ const ex_process return () -- | eval an ex command to an YiM (), also appends to the ex history@@ -1542,7 +1563,7 @@ fn ('t':'a':'b':'m':' ':n) = withEditor (moveTab $ Just (read n)) fn "tabnew" = withEditor $ do newTabE- newTempBufferE+ discard newTempBufferE return () fn ('t':'a':'b':'e':' ':f) = withEditor newTabE >> viFnewE f @@ -1639,7 +1660,7 @@ leaveInsRep :: VimMode leaveInsRep = do- oneOf [spec KEsc, ctrlCh '[', ctrlCh 'c']+ discard $ oneOf [spec KEsc, ctrlCh '[', ctrlCh 'c'] adjustPriority (-1) write $ commitLastInsertionE >> withBuffer0 (setMarkHere '^') startTopKeymap keymapSet@@ -1649,7 +1670,7 @@ ins_mode :: ModeMap -> VimMode ins_mode self = do startInsertKeymap keymapSet- many (v_ins_char self <|> kwd_mode (v_opts self))+ discard $ many (v_ins_char self <|> kwd_mode (v_opts self)) leaveInsRep write $ moveXorSol 1
src/library/Yi/KillRing.hs view
@@ -11,10 +11,8 @@ ) where -import Control.Monad (ap) import Data.Binary import Data.DeriveTH-import Data.Derive.Binary import Yi.Buffer.Basic data Killring = Killring { krKilled :: Bool
+ src/library/Yi/Layout.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, DeriveFunctor, TupleSections, ViewPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} -- we might as well unbox our Ints.++-- | This module defines the layout manager interface (see 'LayoutManager'). To desgin a new layout manager, just make an instance of this class.+module Yi.Layout+ (+ -- * Concrete layouts+ Layout(..),+ Orientation(..),+ DividerPosition,+ DividerRef,+ RelativeSize,+ dividerPositionA,++ -- * Layout managers+ -- ** The interface+ LayoutManager(..),+ AnyLayoutManager(..),+ layoutManagerSameType,+ -- ** Standard managers+ wide,+ tall,+ slidyTall,+ slidyWide,+ hPairNStack,+ vPairNStack,+ -- * Utility functions+ -- ** Layouts as rectangles+ Rectangle(..),+ layoutToRectangles,+ -- ** Transposing things+ Transposable(..),+ Transposed(..),+ -- ** 'DividerRef' combinators+ -- $divRefCombinators+ LayoutM,+ pair,+ singleWindow,+ stack,+ evenStack,+ runLayoutM,+ )+ where++import Prelude()+import Data.Accessor.Basic+import Yi.Prelude+import Data.Typeable+import Data.Maybe+import Data.List(length, splitAt)+import qualified Control.Monad.State.Strict as Monad++-------------------------------- Some design notes ----------------------+-- [Treatment of mini windows]++-- Mini windows are not subject to layout; instead, they are always+-- placed at the bottom of the screen. There are multiple reasons for+-- this, as discussed in+-- https://groups.google.com/d/topic/yi-devel/vhTObC25dpY/discussion, one+-- being that for many layouts, the bottom (or top) of the screen is the+-- only reasonable place for mini windows (for example, think about+-- side-by-side layouts).++-- [Design of the 'Layout' datatype]++-- The 'Layout' datatype is currently implemented in terms of+-- horizontal stacks and vertical stacks. An alternative approach,+-- which xmonad uses, is the following: a 'Layout a' could be a+-- function @a -> Rectangle@ which specifies in coordinates where a+-- window should be placed.+--+-- While this alternative is more flexible than the current approach+-- in allowing spiral layouts and the like, the vty UI doesn't support+-- this: only vertical and horizontal composition of images is+-- allowed.++++----------------------------------- Concrete 'Layout's.+-- | UI-agnostic layout schema. The basic constructs are+-- (horizontal/vertical) stacks with fixed ratios between window+-- sizes; and (horizontal/vertical) pairs with a slider in between (if+-- available).+data Layout a+ = SingleWindow a+ | Stack {+ orientation :: !Orientation, -- ^ Orientation+ wins :: [(Layout a, RelativeSize)] -- ^ The layout stack, with the given weights+ -- TODO: fix strictness for stack (it's still lazy)+ }+ | Pair {+ orientation :: !Orientation, -- ^ Orientation+ divPos :: !DividerPosition, -- ^ Initial position of the divider+ divRef :: !DividerRef, -- ^ Index of the divider (for updating the divider position)+ pairFst :: !(Layout a), -- ^ Upper of of the pair+ pairSnd :: !(Layout a) -- ^ Lower of the pair+ }+ deriving(Typeable, Eq, Functor)++-- | Accessor for the 'DividerPosition' with given reference+dividerPositionA :: DividerRef -> Accessor (Layout a) DividerPosition+dividerPositionA ref = fromSetGet setter getter where+ setter pos = set'+ where+ set' s@(SingleWindow _) = s+ set' p@Pair{} | divRef p == ref = p{ divPos = pos }+ | otherwise = p{ pairFst = set' (pairFst p), pairSnd = set' (pairSnd p) }+ set' s@Stack{} = s{ wins = fmap (\(l, r) -> (set' l, r)) (wins s) }++ getter = fromMaybe invalidRef . get'++ get' (SingleWindow _) = Nothing+ get' p@Pair{} | divRef p == ref = Just (divPos p)+ | otherwise = get' (pairFst p) <|> get' (pairSnd p)+ get' s@Stack{} = foldl' (<|>) Nothing (fmap (get' . fst) (wins s))++ invalidRef = error "Yi.Layout.dividerPositionA: invalid DividerRef"++instance Show a => Show (Layout a) where+ show (SingleWindow a) = show a+ show (Stack o s) = show o ++ " stack " ++ show s+ show p@(Pair{}) = show (orientation p) ++ " " ++ show (pairFst p, pairSnd p)++-- | The initial layout consists of a single window+instance Initializable a => Initializable (Layout a) where+ initial = SingleWindow initial++-- | Orientations for 'Stack' and 'Pair'+data Orientation+ = Horizontal+ | Vertical+ deriving(Eq, Show)++-- | Divider reference+type DividerRef = Int++-- | Divider position, in the range (0,1)+type DividerPosition = Double++-- | Relative sizes, for 'Stack'+type RelativeSize = Double++----------------------------------------------------- Layout managers+-- TODO: add Binary requirement when possible+-- | The type of layout managers. See the layout managers 'tall', 'hPairNStack' and 'slidyTall' for some example implementations.+class (Typeable m, Eq m) => LayoutManager m where+ -- | Given the old layout and the new list of windows, construct a+ -- layout for the new list of windows.+ --+ -- If the layout manager uses sliding dividers, then a user will expect that most+ -- of these dividers don't move when adding a new window. It is the layout+ -- manager's responsibility to ensure that this is the case, and this is the+ -- purpose of the @Layout a@ argument.+ --+ -- The old layout may come from a different layout manager, in which case the layout manager is free to ignore it.+ pureLayout :: m -> Layout a -> [a] -> Layout a+ -- | Describe the layout in a form suitable for the user.+ describeLayout :: m -> String+ -- | Cycles to the next variant, if there is one (the default is 'id')+ nextVariant :: m -> m+ nextVariant = id+ -- | Cycles to the previous variant, if there is one (the default is 'id'+ previousVariant :: m -> m+ previousVariant = id++-- | Existential wrapper for 'Layout'+data AnyLayoutManager = forall m. LayoutManager m => AnyLayoutManager !m+ deriving(Typeable)++instance Eq AnyLayoutManager where+ (AnyLayoutManager l1) == (AnyLayoutManager l2) = maybe False (== l2) (cast l1)++instance LayoutManager (AnyLayoutManager) where+ pureLayout (AnyLayoutManager l) = pureLayout l+ describeLayout (AnyLayoutManager l) = describeLayout l+ nextVariant (AnyLayoutManager l) = AnyLayoutManager (nextVariant l)+ previousVariant (AnyLayoutManager l) = AnyLayoutManager (previousVariant l)++-- | The default layout is 'tallLayout'+instance Initializable AnyLayoutManager where+ initial = hPairNStack 1++-- | True if the internal layout managers have the same type (but are not necessarily equal).+layoutManagerSameType :: AnyLayoutManager -> AnyLayoutManager -> Bool+layoutManagerSameType (AnyLayoutManager l1) (AnyLayoutManager l2) = typeOf l1 == typeOf l2++------------------------------ Standard layouts+-- | Tall windows (i.e. places windows side-by-side, equally spaced)+data Tall = Tall+ deriving(Eq, Typeable)++-- | Windows placed side-by-side, equally spaced.+tall :: AnyLayoutManager+tall = AnyLayoutManager Tall++instance LayoutManager Tall where+ pureLayout Tall _oldLayout ws = runLayoutM $ evenStack Horizontal (fmap singleWindow ws)+ describeLayout Tall = "Windows positioned side-by-side"++-- | Wide windows (windows placed on top of one another, equally spaced)+data Wide = Wide+ deriving(Eq, Typeable)++instance LayoutManager Wide where+ pureLayout Wide _oldLayout ws = runLayoutM $ evenStack Vertical (fmap singleWindow ws)+ describeLayout Wide = "Windows positioned above one another"++-- | Windows placed on top of one another, equally spaced+wide :: AnyLayoutManager+wide = AnyLayoutManager Wide++-- | Tall windows, with arranged in a balanced binary tree with sliders in between them+data SlidyTall = SlidyTall+ deriving(Eq, Typeable)++-- | Tall windows, arranged in a balanced binary tree with sliders in between them.+slidyTall :: AnyLayoutManager+slidyTall = AnyLayoutManager SlidyTall++instance LayoutManager SlidyTall where+ -- an error on input [] is easier to debug than an infinite loop.+ pureLayout SlidyTall _oldLayout [] = error "Yi.Layout: empty window list unexpected"+ pureLayout SlidyTall oldLayout xs = runLayoutM (go (Just oldLayout) xs) where+ go _layout [x] = singleWindow x+ go layout (splitList -> (lxs, rxs)) =+ case layout of+ -- if the old layout had a pair in the same point of the tree, use its divider position+ Just (Pair Horizontal pos _ l r) -> pair Horizontal pos (go (Just l) lxs) (go (Just r) rxs)+ -- otherwise, just use divider position 0.5+ _ -> pair Horizontal 0.5 (go Nothing lxs) (go Nothing rxs)++ describeLayout SlidyTall = "Slidy tall windows, with balanced-position sliders"++splitList :: [a] -> ([a], [a])+splitList xs = splitAt ((length xs + 1) `div` 2) xs++-- | Transposed version of 'SlidyTall'+newtype SlidyWide = SlidyWide (Transposed SlidyTall)+ deriving(Eq, Typeable)++-- | Transposed version of 'slidyTall'+slidyWide :: AnyLayoutManager+slidyWide = AnyLayoutManager (SlidyWide (Transposed (SlidyTall)))++instance LayoutManager SlidyWide where+ pureLayout (SlidyWide w) = pureLayout w+ describeLayout _ = "Slidy wide windows, with balanced-position sliders"++-- | Fixed number of \"main\" windows on the left; stack of windows on the right+data HPairNStack = HPairNStack !Int+ deriving(Eq, Typeable)++-- | @n@ windows on the left; stack of windows on the right.+hPairNStack :: Int -> AnyLayoutManager+hPairNStack n | n < 1 = error "Yi.Layout.hPairNStackLayout: n must be at least 1"+ | otherwise = AnyLayoutManager (HPairNStack n)++instance LayoutManager HPairNStack where+ pureLayout (HPairNStack n) oldLayout (fmap singleWindow -> xs)+ | length xs <= n = runLayoutM $ evenStack Vertical xs+ | otherwise = runLayoutM $ case splitAt n xs of+ (ls, rs) -> pair Horizontal pos+ (evenStack Vertical ls)+ (evenStack Vertical rs)+ where+ pos = case oldLayout of+ Pair Horizontal pos' _ _ _ -> pos'+ _ -> 0.5++ describeLayout (HPairNStack n) = show n ++ " windows on the left; remaining windows on the right"+ nextVariant (HPairNStack n) = HPairNStack (n+1)+ previousVariant (HPairNStack n) = HPairNStack (max (n-1) 1)++newtype VPairNStack = VPairNStack (Transposed HPairNStack)+ deriving(Eq, Typeable)++-- | Transposed version of 'hPairNStack'.+vPairNStack :: Int -> AnyLayoutManager+vPairNStack n = AnyLayoutManager (VPairNStack (Transposed (HPairNStack n)))++instance LayoutManager VPairNStack where+ pureLayout (VPairNStack lm) = pureLayout lm+ previousVariant (VPairNStack lm) = VPairNStack (previousVariant lm)+ nextVariant (VPairNStack lm) = VPairNStack (nextVariant lm)+ describeLayout (VPairNStack (Transposed (HPairNStack n))) = show n ++ " windows on top; remaining windows beneath"++----------------------- Utils++-- | A general bounding box+data Rectangle = Rectangle { rectX, rectY, rectWidth, rectHeight :: !Double }+ deriving(Eq, Show)++layoutToRectangles :: Rectangle -> Layout a -> [(a, Rectangle)]+layoutToRectangles bounds (SingleWindow a) = [(a, bounds)]+layoutToRectangles bounds (Stack o ts) = handleStack o bounds ts+layoutToRectangles bounds (Pair o p _ a b) = handleStack o bounds [(a,p), (b,1-p)]++handleStack :: Orientation -> Rectangle -> [(Layout a, RelativeSize)] -> [(a, Rectangle)]+handleStack o bounds tiles =+ let (totalSpace, startPos, mkBounds) = case o of+ Vertical -> (rectHeight bounds, rectY bounds, \pos size -> bounds{rectY = pos, rectHeight=size})+ Horizontal -> (rectWidth bounds, rectX bounds, \pos size -> bounds{rectX = pos, rectWidth=size})++ totalWeight' = sum (fmap snd tiles)+ totalWeight = if totalWeight' > 0 then totalWeight' else error "Yi.Layout: Stacks must have positive weights"+ spacePerWeight = totalSpace / totalWeight+ doTile pos (t, wt) = (pos + wt * spacePerWeight,+ layoutToRectangles (mkBounds pos (wt * spacePerWeight)) t)+ in+ concat . snd . mapAccumL doTile startPos $ tiles++----------- Flipping things+-- | Things with orientations which can be flipped+class Transposable r where transpose :: r -> r+instance Transposable Orientation where { transpose Horizontal = Vertical; transpose Vertical = Horizontal }+instance Transposable (Layout a) where+ transpose (SingleWindow a) = SingleWindow a+ transpose (Stack o ws) = Stack (transpose o) (fmap (\(l,r) -> (transpose l,r)) ws)+ transpose (Pair o p r a b) = Pair (transpose o) p r (transpose a) (transpose b)++-- | Same as 'lm', but with all 'Orientation's 'transpose'd. See 'slidyWide' for an example of its use.+newtype Transposed lm = Transposed lm+ deriving(Eq, Typeable)++instance LayoutManager lm => LayoutManager (Transposed lm) where+ pureLayout (Transposed lm) l ws = transpose (pureLayout lm (transpose l) ws)+ describeLayout (Transposed lm) = "Transposed version of: " ++ describeLayout lm+ nextVariant (Transposed lm) = Transposed (nextVariant lm)+ previousVariant (Transposed lm) = Transposed (previousVariant lm)++-------------------- 'DividerRef' combinators+-- $divRefCombinators+-- It is tedious and error-prone for 'LayoutManager's to assign 'DividerRef's themselves. Better is to use these monadic smart constructors for 'Layout'. For example, the layout+--+-- @'Pair' 'Horizontal' 0.5 0 ('Pair' 'Vertical' 0.5 1 ('SingleWindow' w1) ('SingleWindow' w2)) ('SingleWindow' w3)@+--+-- could be with the combinators below as+--+-- @'runLayoutM' $ 'pair' 'Horizontal' 0.5 ('pair' 'Vertical' 0.5 ('singleWindow' w1) ('singleWindow' w2)) ('singleWindow' w3)@+--+-- These combinators do will also ensure strictness of the 'wins' field of 'Stack'. They also tidy up and do some error checking: length-1 stacks are removed (they are unnecessary); length-0 stacks raise errors.++-- | A 'Layout a' wrapped in a state monad for tracking 'DividerRef's. This type is /not/ itself a monad, but should rather be thought of as a 'DividerRef'-free version of the 'Layout' type.+newtype LayoutM a = LayoutM (Monad.State DividerRef (Layout a))++singleWindow :: a -> LayoutM a+singleWindow a = LayoutM (pure (SingleWindow a))++pair :: Orientation -> DividerPosition -> LayoutM a -> LayoutM a -> LayoutM a+pair o p (LayoutM l1) (LayoutM l2) = LayoutM $ do+ ref <- Monad.get+ Monad.put (ref+1)+ Pair o p ref <$> l1 <*> l2++stack :: Orientation -> [(LayoutM a, RelativeSize)] -> LayoutM a+stack _ [] = error "Yi.Layout: Length-0 stack"+stack _ [l] = fst l+stack o ls = LayoutM (Stack o <$> mapM (\(LayoutM lm,rs) -> (,rs) <$> lm) ls)++-- | Special case of 'stack' with all 'RelativeSize's equal.+evenStack :: Orientation -> [LayoutM a] -> LayoutM a+evenStack o ls = stack o (fmap (\l -> (l,1)) ls)++runLayoutM :: LayoutM a -> Layout a+runLayoutM (LayoutM l) = Monad.evalState l 0
src/library/Yi/Lexer/Alex.hs view
@@ -150,6 +150,7 @@ -- (this is to support ^,$ in regexes) [] -> [] ((_,ch):rest) -> unfoldLexer l (st, (ch, rest))+ , scanEmpty = error "Yi.Lexer.Alex.lexScanner: scanEmpty" } -- | unfold lexer function into a function that returns a stream of (state x token)
+ src/library/Yi/Lexer/GitCommit.x view
@@ -0,0 +1,100 @@+-- -*- haskell -*-+-- Maintainer: Andrew Myers+{+{-# OPTIONS -w #-}+module Yi.Lexer.GitCommit+ ( initState, alexScanToken )+where+import Data.Monoid (mappend)+import Yi.Lexer.Alex+import Yi.Style ( StyleName )+import qualified Yi.Style as Style+}++$commitChars = [$printable\t] # [\#]+@diffStart = diff\ \-\-git\ $commitChars*+$nl = [\n\r]+$notColon = $printable # [:]++gitCommit :-++-- The first line of a git commit message is the digest that is+-- displayed as a summary of the commit in virtually all git tools.+<0> {+.+ { c Style.regexStyle }+$nl { m (const SecondLine) Style.defaultStyle }+}++-- There should never be anything on the second line of a git commit message+-- so it is styled in a deliberately hideous color scheme.+<secondLine> {+.+ { c (const $ Style.withFg Style.red `mappend` Style.withBg Style.brown) }+$nl { m (const MessageLine) Style.defaultStyle }+}++-- The body of a commit message is broken up as follows+-- * User's message+-- * git generated information in comments+-- * optional diff if commit was run with the -v option.+<body> {+^@diffStart$ { m (const $ DiffDeclaration) Style.regexStyle }+\# { m (const $ LineComment) Style.commentStyle }+$commitChars*$ { c Style.defaultStyle }+$white { c Style.defaultStyle }+. { c Style.defaultStyle }+}++-- Inside git generated comments specific information about what this+-- commit will do is displayed. Highlight keywords and filenames.+-- The notColon rule highlights filenames not preceded by keywords.+-- The specific keywords rules switch to <keyword> context to highlight+-- everything to the end of the line (which should only ever be a filename.)+<lineComment> {+$nl { m (const MessageLine) Style.defaultStyle }+\t$notColon+$ { c Style.preprocessorStyle }+"modified:" { m (const Keyword) Style.keywordStyle }+"new file:" { m (const Keyword) Style.keywordStyle }+"deleted:" { m (const Keyword) Style.keywordStyle }+. { c Style.commentStyle }+}++<keyword> {+$nl { m (const MessageLine) Style.defaultStyle }+. { c Style.preprocessorStyle }+}++-- Highlight diff lines+<diff> {+^@diffStart$ { c Style.regexStyle }+^\@\@.* { c Style.keywordStyle }+^\- .*$ { c Style.commentStyle }+^\+ .*$ { c Style.operatorStyle }+^.*$ { c Style.defaultStyle }+$white { c Style.defaultStyle }+. { c Style.defaultStyle }+}++{++data HlState = Digest+ | SecondLine+ | Keyword+ | MessageLine+ | LineComment+ | DiffDeclaration+ deriving (Show, Eq)++stateToInit Digest = 0+stateToInit SecondLine = secondLine+stateToInit Keyword = keyword+stateToInit MessageLine = body+stateToInit DiffDeclaration = diff+stateToInit LineComment = lineComment++initState :: HlState+initState = Digest++type Token = StyleName+#include "common.hsinc"+}+
+ src/library/Yi/Lexer/Java.x view
@@ -0,0 +1,188 @@+-- -*- haskell -*- +-- Simple lexer for c++{+{-# OPTIONS -w #-} -- Alex generate warnings-ridden code.+module Yi.Lexer.Java ( initState, alexScanToken ) where++{- Standard Library Modules Imported -}+import Yi.Lexer.Alex++{- External Library Modules Imported -}++{- Local Modules Imported -}+import qualified Yi.Syntax+import Yi.Style++}++$whitechar = [\ \t\n\r\f\v]+$special = [\(\)\,\;\[\]\`\{\}]++$ascdigit = 0-9+$unidigit = [] -- TODO+$digit = [$ascdigit $unidigit]++$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]+$unisymbol = [] -- TODO+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']++$large = [A-Z \xc0-\xd6 \xd8-\xde]+$small = [a-z \xdf-\xf6 \xf8-\xff \_]+$alpha = [$small $large]++$graphic = [$small $large $symbol $digit $special \:\"\']++$octit = 0-7+$hexit = [0-9 A-F a-f]+$idchar = [$alpha $digit \']+$symchar = [$symbol \:]+$nl = [\n\r]++@keywordid =+ abstract+ | assert+ | break+ | catch+ | class+ | case+ | const+ | continue+ | default+ | except+ | extends+ | else+ | false+ | finally+ | goto+ | final+ | for+ | if+ | implements+ | import+ | instanceof+ | interface+ | long+ | native+ | new+ | null+ | package+ | private+ | protected+ | public+ | return+ | static+ | switch+ | unsigned+ | volatile+ | while+ | super+ | switch+ | synchronized+ | this+ | throw+ | throws+ | true+ | transient+ | try+ | void+ | volatile+ | while++@builtinTypes =+ char+ | byte+ | boolean+ | double+ | enum+ | float+ | int+ | long+ | short+ | void+ | String+ | Integer+ | Float+ | Double+ | Long++@reservedop = + "+" | "++" | "+=" | "-" | "--" | "-=" | "*" | "*=" | "/" | "/=" | "%" | "%=" |+ "<" | "<=" | ">" | ">=" | "!=" | "==" |+ "!" | "&&" | "||" |+ "<<" | "<<=" | ">>" | ">>=" | "~" | "&" | "&=" | "|" | "|=" | "^" | "^=" |+ "=" | "->" | "." | "," | "?" | ":" ++@varid = $small $idchar*+@conid = $large $idchar*+@varsym = $symbol $symchar*+@consym = \: $symchar*++@decimal = $digit++@octal = $octit++@hexadecimal = $hexit++@exponent = [eE] [\-\+] @decimal++$cntrl = [$large \@\[\\\]\^\_]+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM+ | SUB | ESC | FS | GS | RS | US | SP | DEL+$charesc = [abfnrtv\\\"\'\&]+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)+@gap = \\ $whitechar+ \\+@string = $graphic # [\"\\] | " " | @escape | @gap++java :-++<0> $white+ { c defaultStyle } -- whitespace++<nestcomm> {+ "*/" { m (+1) blockCommentStyle }+ $white+ ; -- Whitespace+ . { c blockCommentStyle }+}++<0> {+ "//"[^\n]* { c commentStyle }++ "/*" @reservedop* { m (subtract 1) blockCommentStyle }++ $special { c defaultStyle }++ @keywordid { c keywordStyle }+ @builtinTypes { c typeStyle }+ @varid { c defaultStyle }+ @conid { c typeStyle }++ @reservedop { c operatorStyle }+ @varsym { c operatorStyle }+ @consym { c typeStyle }++ @decimal + | 0[oO] @octal+ | 0[xX] @hexadecimal { c defaultStyle }++ @decimal \. @decimal @exponent?+ | @decimal @exponent { c defaultStyle }++ \' ($graphic # [\'\\] | " " | @escape) \' { c stringStyle }+ \" @string* \" { c stringStyle }+ . { c operatorStyle }+}+++{++type HlState = Int+type Token = StyleName++stateToInit :: HlState -> Int+stateToInit x | x < 0 = nestcomm+ | otherwise = 0++initState :: HlState+initState = 0++#include "common.hsinc"+}
src/library/Yi/Main.hs view
@@ -6,7 +6,14 @@ -- | This is the main module of Yi, called with configuration from the user. -- Here we mainly process command line arguments. -module Yi.Main (main) where+module Yi.Main (+ -- * Static main+ main, + -- * Command line processing+ do_args,+ ConsoleConfig(..),+ Err(..),+ ) where import Prelude () @@ -15,7 +22,6 @@ import Data.List (intercalate) import Distribution.Text (display) import System.Console.GetOpt-import System.Environment (getArgs) import System.Exit #include "ghcconfig.h" @@ -43,6 +49,21 @@ instance Error Err where strMsg s = Err s (ExitFailure 1) +-- | Configuration information which can be set in the command-line, but not+-- in the user's configuration file.+data ConsoleConfig = + ConsoleConfig {+ ghcOptions :: [String],+ selfCheck :: Bool+ }++defaultConsoleConfig :: ConsoleConfig+defaultConsoleConfig = + ConsoleConfig { + ghcOptions = [],+ selfCheck = False+ }+ -- --------------------------------------------------------------------- -- | Argument parsing. Pretty standard. @@ -54,6 +75,7 @@ | Frontend String | ConfigFile String | SelfCheck+ | GhcOption String | Debug -- | List of editors for which we provide an emulation.@@ -72,6 +94,7 @@ , Option [] ["debug"] (NoArg Debug) "Write debug information in a log file" , Option ['l'] ["line"] (ReqArg LineNo "NUM") "Start on line number" , Option [] ["as"] (ReqArg EditorNm "EDITOR") editorHelp+ , Option [] ["ghc-option"] (ReqArg GhcOption "OPTION") "Specify option to pass to ghc when compiling configuration file" ] where frontendHelp = ("Select frontend, which can be one of:\n" ++ intercalate ", " frontendNames) editorHelp = ("Start with editor keymap, where editor is one of:\n"@@ -84,53 +107,48 @@ versinfo = "yi " ++ display version -- | Transform the config with options-do_args :: Config -> [String] -> Either Err Config+do_args :: Config -> [String] -> Either Err (Config, ConsoleConfig) do_args cfg args = case (getOpt (ReturnInOrder File) options args) of- (o, [], []) -> foldM getConfig cfg o+ (o, [], []) -> foldM getConfig (cfg, defaultConsoleConfig) o (_, _, errs) -> fail (concat errs) -- | Update the default configuration based on a command-line option.-getConfig :: Config -> Opts -> Either Err Config-getConfig cfg opt =+getConfig :: (Config, ConsoleConfig) -> Opts -> Either Err (Config, ConsoleConfig)+getConfig (cfg,cfgcon) opt = case opt of Frontend f -> case lookup f availableFrontends of- Just frontEnd -> return cfg { startFrontEnd = frontEnd }+ Just frontEnd -> return (cfg { startFrontEnd = frontEnd }, cfgcon) Nothing -> fail "Panic: frontend not found" Help -> throwError $ Err usage ExitSuccess Version -> throwError $ Err versinfo ExitSuccess- Debug -> return cfg { debugMode = True }+ Debug -> return (cfg { debugMode = True }, cfgcon) LineNo l -> case startActions cfg of- x : xs -> return cfg { startActions = x:makeAction (gotoLn (read l)):xs }+ x : xs -> return (cfg { startActions = x:makeAction (gotoLn (read l)):xs }, cfgcon) [] -> fail "The `-l' option must come after a file argument" File filename -> prependAction (editFile filename) EditorNm emul -> case lookup (fmap toLower emul) editors of- Just modifyCfg -> return $ modifyCfg cfg+ Just modifyCfg -> return $ (modifyCfg cfg, cfgcon) Nothing -> fail $ "Unknown emulation: " ++ show emul- _ -> return cfg+ GhcOption ghcOpt -> return (cfg, cfgcon { ghcOptions = ghcOptions cfgcon ++ [ghcOpt] })+ _ -> return (cfg, cfgcon) where - prependAction a = return $ cfg { startActions = makeAction a : startActions cfg}+ prependAction a = return $ (cfg { startActions = makeAction a : startActions cfg}, cfgcon) -- --------------------------------------------------------------------- -- | Static main. This is the front end to the statically linked -- application, and the real front end, in a sense. 'dynamic_main' calls -- this after setting preferences passed from the boot loader. ---main :: Config -> Maybe Editor -> IO ()-main cfg state = do+main :: (Config, ConsoleConfig) -> Maybe Editor -> IO ()+main (cfg, cfgcon) state = do #ifdef FRONTEND_COCOA withAutoreleasePool $ do #endif- args <- getArgs #ifdef TESTING- when ("--self-check" `elem` args)+ when (selfCheck cfgcon) TestSuite.main #endif- case do_args cfg args of- Left (Err err code) ->- do putStrLn err- exitWith code- Right finalCfg ->- do when (debugMode finalCfg) $ initDebug ".yi.dbg"- startEditor finalCfg state+ when (debugMode cfg) $ initDebug ".yi.dbg"+ startEditor cfg state
src/library/Yi/MiniBuffer.hs view
@@ -21,11 +21,9 @@ import Yi.Config import Yi.Core import Yi.History-import Yi.Completion (commonPrefix, infixMatch, prefixMatch, containsMatch', completeInList, completeInList')+import Yi.Completion (infixMatch, prefixMatch, containsMatch', completeInList, completeInList') import Yi.Style (defaultStyle)-import Yi.Window ( wkey ) import qualified Yi.Core as Editor-import Control.Monad.Reader import qualified Data.Rope as R -- | Open a minibuffer window with the given prompt and keymap@@ -130,7 +128,7 @@ showMatchingsOf "" withEditor $ do historyStartGen prompt- spawnMinibufferE (prompt ++ " ") (\bindings -> rebindings <|| (bindings >> write showMatchings))+ discard $ spawnMinibufferE (prompt ++ " ") (\bindings -> rebindings <|| (bindings >> write showMatchings)) withBuffer0 $ replaceBufferContent proposal @@ -195,6 +193,40 @@ instance Promptable Int where getPromptedValue = return . read getPrompt _ = "Integer"++-- helper functions:+getPromptedValueList :: [(String,a)] -> String -> YiM a+getPromptedValueList vs s = maybe (error "Invalid choice") return (lookup s vs)++getMinibufferList :: [(String,a)] -> a -> String -> (String -> YiM ()) -> YiM ()+getMinibufferList vs _ prompt act = withMinibufferFin prompt (fmap fst vs) act++enumAll :: (Enum a, Bounded a, Show a) => [(String, a)]+enumAll = (fmap (\v -> (show v, v)) [minBound..])++instance Promptable Direction where+ getPromptedValue = getPromptedValueList enumAll+ getPrompt _ = "Direction"+ getMinibuffer = getMinibufferList enumAll++textUnits :: [(String, TextUnit)]+textUnits =+ [("Character", Character),+ ("Document", Document),+ ("Line", Line),+ ("Paragraph", unitParagraph),+ ("Word", unitWord),+ ("ViWord", unitViWord)+ ]++instance Promptable TextUnit where+ getPromptedValue = getPromptedValueList textUnits+ getPrompt _ = "Unit"+ getMinibuffer = getMinibufferList textUnits++instance Promptable Point where+ getPromptedValue s = Point <$> getPromptedValue s+ getPrompt _ = "Point" anyModeName :: AnyMode -> String anyModeName (AnyMode m) = modeName m
src/library/Yi/Misc.hs view
@@ -25,7 +25,6 @@ ( doesDirectoryExist , getDirectoryContents , getCurrentDirectory- , canonicalizePath ) import Control.Monad.Trans (MonadIO (..))@@ -36,11 +35,10 @@ import Yi.Core import Yi.MiniBuffer- ( withMinibuffer- , simpleComplete+ ( simpleComplete , withMinibufferGen )-+import System.CanonicalizePath (canonicalizePath) -- | Given a possible starting path (which if not given defaults to -- the current directory) and a fragment of a path we find all
src/library/Yi/Mode/Abella.hs view
@@ -46,6 +46,7 @@ newtype AbellaBuffer = AbellaBuffer {_abellaBuffer :: Maybe BufferRef} deriving (Initializable, Typeable, Binary)+instance YiVariable AbellaBuffer getProofPointMark :: BufferM Mark getProofPointMark = getMarkB $ Just "p"
src/library/Yi/Mode/Buffers.hs view
@@ -6,8 +6,6 @@ ) where import Yi.Core-import Yi.Keymap-import Yi.Editor import Yi.Buffer import Data.List ( intercalate ) import System.FilePath ( takeFileName )
src/library/Yi/Mode/Compilation.hs view
@@ -7,7 +7,6 @@ import Yi.Lexer.Alex (Tok(..), Posn(..)) import Yi.Style import Yi.Modes (linearSyntaxMode)-import qualified Yi.Lexer.Alex as Alex import qualified Yi.Lexer.Compilation as Compilation import qualified Yi.Syntax.OnlineTree as OnlineTree @@ -26,9 +25,9 @@ Just (t@Tok {tokT = Compilation.Report filename line col _message}) -> do withBuffer $ moveTo $ posnOfs $ tokPosn $ t shiftOtherWindow- editFile filename+ discard $ editFile filename withBuffer $ do - gotoLn line+ discard $ gotoLn line rightN col _ -> return ()
src/library/Yi/Mode/Haskell.hs view
@@ -222,9 +222,9 @@ -- offer add another statement in the block stopsOf ((Hask.PGuard' (PAtom pipe _) _ _):ts') = [tokCol pipe | lineStartsWith (ReservedOp Haskell.Pipe)] ++ stopsOf ts' -- offer to align against another guard- stopsOf (d@(Hask.PData _ _ _ r):ts') = colOf' d + indentLevel+ stopsOf (d@(Hask.PData {}):ts') = colOf' d + indentLevel : stopsOf ts' --FIXME!- stopsOf ((Hask.RHS (Hask.PAtom eq _) (exp)):ts')+ stopsOf ((Hask.RHS (Hask.PAtom{}) (exp)):ts') = [(case firstTokOnLine of Just (Operator op) -> opLength op (colOf' exp) -- Usually operators are aligned against the '=' sign -- case of an operator should check so that value always is at least 1 @@ -237,7 +237,6 @@ in if l > 0 then l else 1 lineStartsWith tok = firstTokOnLine == Just tok- lineIsEquation = any (== ReservedOp Haskell.Equal) toksOnLine lineIsExpression = all (`notElem` [ReservedOp Haskell.Pipe, ReservedOp Haskell.Equal, ReservedOp RightArrow]) toksOnLine && not (lineStartsWith (Reserved Haskell.In)) -- TODO: check the tree instead of guessing by looking at tokens@@ -274,6 +273,7 @@ colOf' :: Foldable t => t TT -> Int colOf' = maybe 0 tokCol . getFirstElement +tokCol :: Tok t -> Int tokCol = posnCol . tokPosn @@ -312,31 +312,32 @@ tokTyp (Comment t) = Just t tokTyp _ = Nothing --- | Keyword-based auto-indenter for haskell.-autoIndentHaskellB :: IndentBehaviour -> BufferM ()-autoIndentHaskellB =- autoIndentWithKeywordsB [ "if"- , "then"- , "else"- , "|"- , "->"- , "case" -- hmm- , "in"- -- Note tempted by having '=' in here that would- -- potentially work well for 'data' declarations- -- but I think '=' is so common in other places- -- that it would introduce many spurious/annoying- -- hints.- ]- [ "where"- , "let"- , "do"- , "mdo"- , "{-"- , "{-|"- , "--"- ]-+-- TODO: export or remove+-- -- | Keyword-based auto-indenter for haskell.+-- autoIndentHaskellB :: IndentBehaviour -> BufferM ()+-- autoIndentHaskellB =+-- autoIndentWithKeywordsB [ "if"+-- , "then"+-- , "else"+-- , "|"+-- , "->"+-- , "case" -- hmm+-- , "in"+-- -- Note tempted by having '=' in here that would+-- -- potentially work well for 'data' declarations+-- -- but I think '=' is so common in other places+-- -- that it would introduce many spurious/annoying+-- -- hints.+-- ]+-- [ "where"+-- , "let"+-- , "do"+-- , "mdo"+-- , "{-"+-- , "{-|"+-- , "--"+-- ]+-- --------------------------- -- * Interaction with GHCi @@ -344,6 +345,7 @@ newtype GhciBuffer = GhciBuffer {_ghciBuffer :: Maybe BufferRef} deriving (Initializable, Typeable, Binary) +instance YiVariable GhciBuffer -- | Start GHCi in a buffer ghci :: YiM BufferRef ghci = do @@ -384,15 +386,15 @@ -- Tells ghci to infer the type of the identifier at point. Doesn't check for errors (yet) ghciInferType :: YiM () ghciInferType = do- name <- withBuffer $ readUnitB unitWord- when (not $ null name) $ - withMinibufferGen name noHint "Insert type of which identifier?" return ghciInferTypeOf+ nm <- withBuffer $ readUnitB unitWord+ when (not $ null nm) $ + withMinibufferGen nm noHint "Insert type of which identifier?" return ghciInferTypeOf ghciInferTypeOf :: String -> YiM ()-ghciInferTypeOf name = do+ghciInferTypeOf nm = do buf <- ghciGet- result <- Interactive.queryReply buf (":t " ++ name)- let successful = (not . null) name &&and (zipWith (==) name result)+ result <- Interactive.queryReply buf (":t " ++ nm)+ let successful = (not . null) nm &&and (zipWith (==) nm result) when successful $ withBuffer $ moveToSol *> insertB '\n' *> leftB *> insertN result *> rightB
src/library/Yi/Mode/Haskell/Dollarify.hs view
@@ -6,7 +6,7 @@ import Data.List (sortBy) import Yi.Prelude import Yi.Syntax.Paren (Expr, Tree(..))-import qualified Yi.Syntax.Haskell as H (Tree(..), Exp(..))+import qualified Yi.Syntax.Haskell as H (Tree, Exp(..)) import Yi.Syntax.Tree (getAllSubTrees, getFirstOffset, getLastOffset,getLastPath) import Yi.Lexer.Alex (posnOfs, Tok(..)) import Yi.Lexer.Haskell (isComment, TT, Token(..))@@ -63,7 +63,7 @@ | isNormalParen p = case stripComments e of [Paren _ _ _] -> [queueDelete t2, queueDelete t1] e' -> dollarifyExpr e'-dollarifyTop (Block list) = dollarifyExpr . stripComments =<< [x | Expr x <- list]+dollarifyTop (Block blk) = dollarifyExpr . stripComments =<< [x | Expr x <- blk] dollarifyTop _ = [] -- Expression must not contain comments
src/library/Yi/Mode/JavaScript.hs view
@@ -7,17 +7,16 @@ import Control.Monad.Writer.Lazy (execWriter) import Data.List (nub) import Data.Maybe (isJust)-import Data.Typeable (Typeable)-import Prelude (unlines, map)+import Prelude (map) import System.FilePath.Posix (takeBaseName) import Yi.Buffer.Basic (BufferRef, Direction(..), fromString) import Yi.Buffer.Indent (indentSettingsB, indentOfB, cycleIndentsB, newlineAndIndentB) import Yi.Buffer.HighLevel (replaceBufferContent, getNextNonBlankLineB, moveToSol) import Yi.Buffer.Misc (Mode(..), BufferM, IndentBehaviour, file, pointAt, shiftWidth)-import Yi.Core ( (.), Mode, emptyMode, modeApplies, modeName+import Yi.Core ( Mode, emptyMode, modeApplies, modeName , modeToggleCommentSelection, toggleCommentSelectionB, modeHL- , Char, modeGetStrokes, ($), withSyntax )-import Yi.Dynamic (Initializable)+ , modeGetStrokes, withSyntax )+import Yi.Dynamic -- import Yi.Debug (traceM, traceM_) import Yi.Editor (withEditor, withOtherWindow, getDynamic, stringToNewBuffer , findBuffer, switchToBufferE)@@ -90,7 +89,9 @@ } newtype JSBuffer = JSBuffer (Maybe BufferRef)- deriving (Initializable, Typeable)+ deriving (Initializable, Typeable, Binary)++instance YiVariable JSBuffer -- | The "compiler." jsCompile :: Tree TT -> YiM ()
src/library/Yi/Modes.hs view
@@ -2,10 +2,11 @@ module Yi.Modes (TokenBasedMode, fundamentalMode, cMode, objectiveCMode, cppMode, cabalMode, srmcMode, ocamlMode, ottMode, gnuMakeMode,- perlMode, pythonMode, anyExtension,+ perlMode, pythonMode, javaMode, anyExtension, extensionOrContentsMatch, linearSyntaxMode, svnCommitMode, hookModes, applyModeHooks,- lookupMode, whitespaceMode, removeAnnots+ lookupMode, whitespaceMode, removeAnnots,+ gitCommitMode ) where import Prelude ()@@ -33,8 +34,10 @@ 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.Java as Java import qualified Yi.Lexer.Srmc as Srmc import qualified Yi.Lexer.SVNCommit as SVNCommit+import qualified Yi.Lexer.GitCommit as GitCommit import qualified Yi.Lexer.Whitespace as Whitespace import Yi.Syntax.OnlineTree as OnlineTree import qualified Yi.IncrementalParse as IncrParser@@ -43,7 +46,7 @@ type StyleBasedMode = TokenBasedMode StyleName fundamentalMode :: Mode syntax-svnCommitMode, cMode, objectiveCMode, cppMode, cabalMode, srmcMode, ottMode, gnuMakeMode, perlMode, pythonMode :: StyleBasedMode+svnCommitMode, cMode, objectiveCMode, cppMode, cabalMode, srmcMode, ottMode, gnuMakeMode, perlMode, pythonMode, javaMode :: StyleBasedMode ocamlMode :: TokenBasedMode (OCaml.Token) fundamentalMode = emptyMode@@ -109,6 +112,13 @@ "srmc"] } +gitCommitMode = (linearSyntaxMode GitCommit.initState GitCommit.alexScanToken id)+ {+ modeName = "git-commit",+ modeApplies = \path _ -> takeFileName path == "COMMIT_EDITMSG" &&+ takeFileName (takeDirectory path) == ".git"+ }+ svnCommitMode = (linearSyntaxMode SVNCommit.initState SVNCommit.alexScanToken id) { modeName = "svn-commit",@@ -138,6 +148,12 @@ } } where base = linearSyntaxMode Python.initState Python.alexScanToken id++javaMode = (linearSyntaxMode Java.initState Java.alexScanToken id)+ {+ modeName = "java",+ modeApplies = anyExtension ["java"]+ } isMakefile :: FilePath -> String -> Bool isMakefile path _contents = matches $ takeFileName path
src/library/Yi/Monad.hs view
@@ -17,7 +17,6 @@ import Data.IORef import Control.Monad.Reader import Control.Monad.State-import Control.Monad.Trans import Control.Concurrent.MVar -- | Combination of the Control.Monad.State 'modify' and 'gets'
src/library/Yi/Prelude.hs view
@@ -5,7 +5,9 @@ (<>), (++), -- consider scrapping this and replacing it by the above (=<<),+($!), Double,+Binary, Char, Either(..), Endom,@@ -13,6 +15,7 @@ Fractional(..), Functor(..), IO,+Initializable(..), Integer, Integral(..), Bounded(..),@@ -27,9 +30,13 @@ ReaderT(..), SemiNum(..), String,+Typeable, commonPrefix, discard,+dummyPut,+dummyGet, every,+findPL, fromIntegral, fst, fst3,@@ -42,6 +49,7 @@ lookup, mapAdjust', mapAlter',+mapFromFoldable, module Control.Applicative, module Control.Category, module Data.Accessor, @@ -65,6 +73,7 @@ singleton, snd, snd3,+swapFocus, tail, trd3, undefined,@@ -76,18 +85,20 @@ import Prelude hiding (any, all) import Yi.Debug import Yi.Monad-import qualified Data.Accessor.Basic import Text.Show import Data.Bool+import Data.Binary import Data.Foldable import Data.Function hiding ((.), id)+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable(Hashable) import Data.Int import Data.Rope (Rope) import Control.Category import Control.Monad.Reader-import Control.Applicative+import Control.Applicative hiding((<$)) import Data.Traversable -import Control.Monad+import Data.Typeable import Data.Monoid import qualified Data.Set as Set import qualified Data.Map as Map@@ -96,6 +107,7 @@ import Data.Accessor ((<.), accessor, getVal, setVal, Accessor,(^.),(^:),(^=)) import qualified Data.Accessor.Monad.FD.State as Accessor.FD import Data.Accessor.Monad.FD.State ((%:), (%=))+import qualified Data.List.PointedList as PL type Endom a = a -> a @@ -157,6 +169,9 @@ -- the structure. +-- | Generalisation of 'Map.fromList' to arbitrary foldables.+mapFromFoldable :: (Foldable t, Ord k) => t (k, a) -> Map.Map k a+mapFromFoldable = foldMap (uncurry Map.singleton) -- | Alternative to groupBy. --@@ -209,10 +224,18 @@ prefix = head heads -- for an alternative implementation see GHC's InteractiveUI module. --+---------------------- PointedList stuff+-- | Finds the first element satisfying the predicate, and returns a zipper pointing at it.+findPL :: (a -> Bool) -> [a] -> Maybe (PL.PointedList a)+findPL p xs = go [] xs where+ go _ [] = Nothing+ go ls (f:rs) | p f = Just (PL.PointedList ls f rs)+ | otherwise = go (f:ls) rs ------------------------+-- | Given a function which moves the focus from index A to index B, return a function which swaps the elements at indexes A and B and then moves the focus. See Yi.Editor.swapWinWithFirstE for an example.+swapFocus :: (PL.PointedList a -> PL.PointedList a) -> (PL.PointedList a -> PL.PointedList a)+swapFocus moveFocus xs = PL.focusA ^= (xs ^. PL.focusA) $ moveFocus $ PL.focusA ^= (moveFocus xs ^. PL.focusA) $ xs+---------------------- -- Acessor stuff putA :: CMSC.MonadState r m => Accessor.T r a -> a -> m ()@@ -223,4 +246,28 @@ modA :: CMSC.MonadState r m => Accessor.T r a -> (a -> a) -> m () modA = Accessor.FD.modify++-------------------- Initializable typeclass+-- | The default value. If a function tries to get a copy of the state, but the state+-- hasn't yet been created, 'initial' will be called to supply *some* value. The value+-- of initial will probably be something like Nothing, \[\], \"\", or 'Data.Sequence.empty' - compare +-- the 'mempty' of "Data.Monoid".+class Initializable a where+ initial :: a++instance Initializable (Maybe a) where+ initial = Nothing++-- | Write nothing. Use with 'dummyGet'+dummyPut :: a -> Put+dummyPut _ = return ()++-- | Read nothing, and return 'initial'. Use with 'dummyPut'.+dummyGet :: Initializable a => Get a+dummyGet = return initial++----------------- Orphan 'Binary' instances+instance (Eq k, Hashable k, Binary k, Binary v) => Binary (HashMap.HashMap k v) where+ put x = put (HashMap.toList x)+ get = HashMap.fromList <$> get
src/library/Yi/Process.hs view
@@ -15,8 +15,9 @@ import Foreign.Marshal.Alloc(allocaBytes) import Foreign.C.String +import Prelude(length, catch)+import Yi.Prelude import Yi.Buffer (BufferRef)-import Yi.Monad(repeatUntilM) #ifndef mingw32_HOST_OS import System.Posix.IO@@ -46,8 +47,8 @@ -- data gets pulled as it becomes available. you have to force the -- output strings before waiting for the process to terminate. --- forkIO (Control.Exception.evaluate (length output) >> return ())- forkIO (Control.Exception.evaluate (length errput) >> return ())+ discard $ forkIO (Control.Exception.evaluate (length output) >> return ())+ discard $ forkIO (Control.Exception.evaluate (length errput) >> return ()) -- And now we wait. We must wait after we read, unsurprisingly. exitCode <- waitForProcess pid -- blocks without -threaded, you're warned.@@ -66,7 +67,7 @@ -- | Run a command using the system shell, returning stdout, stderr and exit code shellFileName :: IO String-shellFileName = Prelude.catch (getEnv "SHELL") (const $ return "/bin/sh")+shellFileName = catch (getEnv "SHELL") (const $ return "/bin/sh") shellCommandSwitch :: String shellCommandSwitch = "-c"
src/library/Yi/Rectangle.hs view
@@ -5,8 +5,6 @@ import Yi.Prelude import Prelude (subtract) import Data.List (splitAt, unzip)-import Control.Applicative-import Data.Char import Data.List (sort, length, zipWith, transpose) import Yi.Buffer
src/library/Yi/Regex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- uniplate uses incomplete patterns -- Copyright (c) Jean-Philippe Bernardy 2008 module Yi.Regex (
src/library/Yi/Region.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} -- Copyright (C) 2008 JP Bernardy -- | This module defines the Region ADT@@ -23,6 +23,8 @@ where import Yi.Buffer.Basic import Data.Typeable+import Data.Binary+import Data.DeriveTH import Yi.Prelude import Prelude () @@ -32,6 +34,8 @@ data Region = Region {regionDirection :: !Direction, regionStart, regionEnd :: !Point} deriving (Typeable)++$(derive makeBinary ''Region) instance Show Region where show r = show (regionStart r) ++
src/library/Yi/Scion.hs view
@@ -14,7 +14,7 @@ import HscTypes import qualified Outputable as O import Scion-import Scion.Types hiding (gets) +import Scion.Types import Scion.Utils import Outputable import GHC.SYB.Utils@@ -74,9 +74,9 @@ mss <- modulesInDepOrder show <$> forM mss (\ms -> do mod <- typecheckModule =<< parseModule ms- let Just (grp, _, _, _, _) = renamedSource mod+ let Just (grp, _, _, _) = renamedSource mod let bnds = typecheckedSource mod- let tyclds = thingsAroundPoint pt (hs_tyclds grp)+ let tyclds = thingsAroundPoint pt $ concat $ hs_tyclds grp let ValBindsOut valds _ = hs_valds grp return $ showData TypeChecker 2 bnds)
src/library/Yi/Search.hs view
@@ -54,7 +54,6 @@ import Data.Maybe import Data.Either import Data.List (span, takeWhile, take, length)- import Yi.Core import Yi.Core as Editor import Yi.History@@ -195,7 +194,8 @@ -- Incremental search -newtype Isearch = Isearch [(String, Region, Direction)] deriving Typeable+newtype Isearch = Isearch [(String, Region, Direction)] + deriving (Typeable, Binary) -- This contains: (string currently searched, position where we -- searched it, direction, overlay for highlighting searched text) @@ -204,6 +204,8 @@ instance Initializable Isearch where initial = (Isearch [])++instance YiVariable Isearch isearchInitE :: Direction -> EditorM () isearchInitE dir = do
src/library/Yi/Snippets.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses,- NoMonomorphismRestriction, TypeSynonymInstances #-}+ NoMonomorphismRestriction, TypeSynonymInstances, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-} module Yi.Snippets where import Prelude () import Yi.Prelude import Control.Arrow-import Control.Monad.RWS hiding (mapM, mapM_, forM, forM_, sequence)+import Control.Monad.RWS hiding (mapM, mapM_, forM, forM_, sequence, get, put)+import Data.Binary+import Data.DeriveTH import Data.List hiding (foldl', find, elem, concat, concatMap) import Data.Char (isSpace) import Data.Maybe (fromJust, isJust)@@ -29,12 +32,14 @@ | ValuedMarkInfo { userIndex :: !Int, startMark :: !Mark, endMark :: !Mark } | DependentMarkInfo { userIndex :: !Int, startMark :: !Mark, endMark :: !Mark } deriving (Eq, Show)++$(derive makeBinary ''MarkInfo) newtype BufferMarks = BufferMarks { bufferMarks :: [MarkInfo] }- deriving (Eq, Show, Monoid, Typeable)+ deriving (Eq, Show, Monoid, Typeable, Binary) newtype DependentMarks = DependentMarks { marks :: [[MarkInfo]] }- deriving (Eq, Show, Monoid, Typeable)+ deriving (Eq, Show, Monoid, Typeable, Binary) instance Initializable BufferMarks where initial = BufferMarks []@@ -42,6 +47,9 @@ instance Initializable DependentMarks where initial = DependentMarks [] +instance YiVariable BufferMarks+instance YiVariable DependentMarks+ instance Ord MarkInfo where a `compare` b = (userIndex a) `compare` (userIndex b) @@ -134,7 +142,7 @@ moveToNextBufferMark deleteLast return a where- len1 (x:[]) = True+ len1 (_:[]) = True len1 _ = False belongTogether a b = userIndex a == userIndex b@@ -206,7 +214,7 @@ then return $ mkRegion p p -- return empty region else f =<< regionOfPartNonEmptyAtB unitViWordOnLine Forward p -markRegion m@(SimpleMarkInfo _ s) = withSimpleRegion m $ \r -> do+markRegion m@SimpleMarkInfo{} = withSimpleRegion m $ \r -> do os <- findOverlappingMarksWith safeMarkRegion concat True r m rOs <- mapM safeMarkRegion os return . mkRegion (regionStart r) $ foldl' minEnd (regionEnd r) rOs
src/library/Yi/Style.hs view
@@ -81,7 +81,7 @@ -- | A style that sets the background. withBg c = Endo $ \s -> s { background = c } -withBd, withItlc, withUnderline :: Bool -> Style+withBd, withItlc, withUnderline, withReverse :: Bool -> Style -- | A style that sets the font to bold withBd c = Endo $ \s -> s { bold = c } -- | A style that sets the style to italics
src/library/Yi/Syntax.hs view
@@ -46,8 +46,8 @@ data Highlighter cache syntax = SynHL { hlStartState :: cache -- ^ The start state for the highlighter. , hlRun :: Scanner Point Char -> Point -> cache -> cache- , hlGetTree :: cache -> Int -> syntax- , hlFocus :: M.Map Int Region -> cache -> cache+ , hlGetTree :: cache -> WindowRef -> syntax+ , hlFocus :: M.Map WindowRef Region -> cache -> cache -- ^ focus at a given point, and return the coresponding node. (hint -- the root can always be returned, at the cost of performance.) }
src/library/Yi/Syntax/Driver.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- Copyright (C) JP Bernardy 2009 -- | This module defines implementations of syntax-awareness drivers.@@ -12,18 +13,18 @@ import qualified Data.Map as M import Data.Map (Map) +import Yi.Buffer.Basic(WindowRef) import Yi.Lexer.Alex (Tok)-import Yi.Region import Yi.Syntax hiding (Cache) import Yi.Syntax.Tree type Path = [Int] data Cache state tree tt = Cache {- path :: M.Map Int Path,+ path :: M.Map WindowRef Path, cachedStates :: [state], root :: tree (Tok tt),- focused :: !(M.Map Int (tree (Tok tt)))+ focused :: !(M.Map WindowRef (tree (Tok tt))) } mkHighlighter :: forall state tree tt. (IsTree tree, Show state) => @@ -51,7 +52,7 @@ recomputed = scanRun newScan resumeState newResult :: tree (Tok tt) newResult = if null recomputed then oldResult else snd $ head $ recomputed- focus r c@(Cache path states root _focused) = + focus r (Cache path states root _focused) = (Cache path' states root focused) where (path', focused) = unzipFM $ zipWithFM (\newpath oldpath -> fromNodeToFinal newpath (oldpath,root)) [] r path
src/library/Yi/Syntax/Haskell.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleInstances, TypeFamilies , TemplateHaskell, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-incomplete-patterns -fno-warn-name-shadowing #-} +-- we have lots of parsers which don't want signatures; and we have uniplate patterns+ -- Copyright (c) Anders Karlsson 2009 -- Copyright (c) JP Bernardy 2009 -- NOTES:@@ -16,7 +19,7 @@ import Prelude () import Data.Maybe-import Data.List (filter, union, takeWhile, (\\))+import Data.List ((\\)) import qualified Data.Foldable import Yi.IncrementalParse import Yi.Lexer.Alex@@ -26,10 +29,7 @@ import Yi.Syntax import Yi.Prelude import Prelude ()-import Data.Monoid import Data.DeriveTH-import Data.Derive.Foldable-import Data.Maybe import Data.Tuple (uncurry) import Control.Arrow ((&&&)) @@ -40,7 +40,7 @@ (Special '[', Special ']'), (Special '{', Special '}')] ignoredToken- [(Special '<'), (Special '>'), (Special '.')]+ ((Special '<'), (Special '>'), (Special '.')) isBrace -- HACK: We insert the Special '<', '>', '.',@@ -60,7 +60,6 @@ type PAtom = Exp type Block = Exp type PGuard = Exp-type BList = Exp type PModule = Exp type PModuleDecl = Exp type PImport = Exp@@ -290,10 +289,10 @@ pKW k r = Bin <$> pAtom k <*> r -- | Parse an unary operator with and without using please-pOP, ppOP :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT)+pOP :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT) pOP op r = Bin <$> pAtom op <*> r -ppOP op r = Bin <$> ppAtom op <*> r+--ppOP op r = Bin <$> ppAtom op <*> r -- | Parse comments pComments :: Parser TT [TT]@@ -535,7 +534,7 @@ pFunDecl = pDecl True True pTypeDecl = pDecl True False-pEquation = pDecl False True+--pEquation = pDecl False True -- | The RHS of an equation.@@ -551,7 +550,7 @@ pBlocks p = p `sepBy1` exact [nextLine] -- | Parse a some of something separated by the token (Special '.'), or nothing--- pBlocks' :: Parser TT r -> Parser TT (BL.BList r)+--pBlocks' :: Parser TT r -> Parser TT (BL.BList r) pBlocks' p = pBlocks p <|> pure [] -- | Parse a block of some something separated by the tok (Special '.')@@ -681,11 +680,11 @@ pCBrack p c = Paren <$> pCAtom [Special '['] c <*> p <*> (recoverAtom <|> pCAtom [Special ']'] c) -pParen, pBrace, pBrack :: Parser TT [Exp TT] -> Parser TT (Exp TT)+pParen, pBrack :: Parser TT [Exp TT] -> Parser TT (Exp TT) pParen = flip pCParen pComments -pBrace = flip pCBrace pComments+--pBrace = flip pCBrace pComments pBrack = flip pCBrack pComments
src/library/Yi/Syntax/Latex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- uniplate patterns -- Copyright (c) JP Bernardy 2008 module Yi.Syntax.Latex where @@ -87,7 +88,7 @@ <|> (Error <$> recoverWith (sym' (not . ((||) <$> isNoise <*> (`elem` openParens))))) getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]-getStrokes point begin _end t0 = appEndo result []+getStrokes point _begin _end t0 = appEndo result [] where getStrokes' :: Tree TT -> Endo [Stroke] getStrokes' (Expr g) = getStrokesL g getStrokes' (Atom t) = ts id t
src/library/Yi/Syntax/Layout.hs view
@@ -40,9 +40,9 @@ layoutHandler :: forall t lexState. (Show t, Eq t) => (t -> Bool) -> [(t,t)] -> (Tok t -> Bool) -> - [t] -> (Tok t -> Bool) ->+ (t,t,t) -> (Tok t -> Bool) -> Scanner (AlexState lexState) (Tok t) -> Scanner (State t lexState) (Tok t)-layoutHandler isSpecial parens isIgnored [openT, closeT, nextT] isGroupOpen lexSource = Scanner +layoutHandler isSpecial parens isIgnored (openT, closeT, nextT) isGroupOpen lexSource = Scanner { scanLooked = scanLooked lexSource . snd, scanEmpty = error "layoutHandler: scanEmpty",@@ -62,7 +62,7 @@ deepestIndent (Indent i:_) = i deepestIndent (_:levs) = deepestIndent levs - deepestParen p [] = False+ deepestParen _ [] = False deepestParen p (Paren t:levs) = p == t || deepestParen p levs deepestParen p (_:levs) = deepestParen p levs
src/library/Yi/Syntax/OnlineTree.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeFamilies, CPP, NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- uniplate patterns module Yi.Syntax.OnlineTree (Tree(..), manyToks, tokAtOrBefore) where import Prelude ()@@ -6,12 +7,9 @@ import Control.Applicative import Data.Traversable import Data.Foldable-import Data.List hiding (foldr, mapAccumL, concat)-import Data.Maybe (maybeToList) import Data.Monoid #ifdef TESTING-import System.Random import Test.QuickCheck import Parser.Incremental #endif@@ -38,7 +36,7 @@ instance IsTree Tree where emptyNode = Tip- uniplate (Bin l r) = ([l,r],\[l,r] -> Bin l r)+ uniplate (Bin l r) = ([l,r],\[l',r'] -> Bin l' r') uniplate t = ([],\_->t) instance Traversable Tree where@@ -62,10 +60,10 @@ manyToks' n = Look (pure Tip) (\_ -> Bin <$> subTree n <*> manyToks' (n * 2)) subTree :: Int -> P a (Tree a)-subTree n = Look (pure Tip) (\s -> +subTree n = Look (pure Tip) (\_ -> case n of 0 -> pure Tip 1 -> Leaf <$> symbol (const True)- n -> let m = n `div` 2 in Bin <$> subTree m <*> subTree m)+ _ -> let m = n `div` 2 in Bin <$> subTree m <*> subTree m)
src/library/Yi/Syntax/Paren.hs view
@@ -14,7 +14,6 @@ import Prelude () import Data.Monoid import Data.DeriveTH-import Data.Derive.Foldable import Data.Maybe import Data.List (filter, takeWhile) import qualified Data.Foldable@@ -24,7 +23,7 @@ indentScanner = layoutHandler startsLayout [(Special '(', Special ')'), (Special '[', Special ']'), (Special '{', Special '}')] ignoredToken- (fmap Special ['<', '>', '.']) isBrace+ (Special '<', Special '>', Special '.') isBrace -- HACK: We insert the Special '<', '>', '.', that don't occur in normal haskell -- parsing.@@ -52,8 +51,8 @@ $(derive makeFoldable ''Tree) instance IsTree Tree where emptyNode = Expr []- uniplate (Paren l g r) = (g,\g -> Paren l g r)- uniplate (Expr g) = (g,\g -> Expr g)+ uniplate (Paren l g r) = (g,\g' -> Paren l g' r)+ uniplate (Expr g) = (g,\g' -> Expr g') uniplate (Block s) = (s,\s' -> Block s') uniplate t = ([],\_ -> t) @@ -99,7 +98,7 @@ parse = Expr <$> parse' tokT tokFromT parse' :: (TT -> Token) -> (Token -> TT) -> P TT [Tree TT]-parse' toTok fromT = pExpr <* eof+parse' toTok _ = pExpr <* eof where -- | parse a special symbol sym c = symbol (isSpecial [c] . toTok)@@ -160,6 +159,7 @@ -- | Create a special error token. (e.g. fill in where there is no correct token to parse) -- Note that the position of the token has to be correct for correct computation of -- node spans.+errTok :: Parser (Tok t) (Tok Token) errTok = mkTok <$> curPos where curPos = tB <$> lookNext tB Nothing = maxBound
src/library/Yi/Syntax/Strokes/Haskell.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ module Yi.Syntax.Strokes.Haskell (getStrokes, tokenToAnnot) where import Prelude ()@@ -9,7 +11,6 @@ import Yi.Prelude import Prelude () import Data.Monoid-import Data.Maybe import Yi.Syntax.Haskell import Yi.Syntax.Tree (subtrees)
src/library/Yi/Syntax/Tree.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TypeFamilies, NoMonomorphismRestriction, FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-incomplete-patterns #-} -- the CPP seems to confuse GHC; we have uniplate patterns {- Copyright JP Bernardy 2008 -} -- | Generic syntax tree handling functions@@ -241,8 +242,8 @@ -- | Given a tree, return (first offset, number of lines). getSubtreeSpan :: (Foldable tree) => tree (Tok t) -> (Point, Int)-getSubtreeSpan tree = (posnOfs $ first, lastLine - firstLine)- where bounds@[first, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree]+getSubtreeSpan tree = (posnOfs $ firstOff, lastLine - firstLine)+ where bounds@[firstOff, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree] [firstLine, lastLine] = fmap posnLine bounds assertJust (Just x) = x assertJust _ = error "assertJust: Just expected"@@ -269,6 +270,7 @@ data Test a = Empty | Leaf a | Bin (Test a) (Test a) deriving (Show, Eq) instance Foldable Test where+ foldMap _ Empty = mempty foldMap f (Leaf x) = f x foldMap f (Bin _ r) = foldMap f r <> foldMap f r @@ -334,7 +336,7 @@ prop_fromLeafAfterToFinal (N n) = let fullRegion = subtreeRegion $ snd n in forAll (pointInside fullRegion) $ \p -> do- let final@(finalPath, (pathFromSubtree, finalSubtree)) = fromLeafAfterToFinal p n+ let final@(_, (_, finalSubtree)) = fromLeafAfterToFinal p n finalRegion = subtreeRegion finalSubtree initialRegion = nodeRegion n @@ -376,7 +378,7 @@ prop_fromNodeToFinal :: NTTT -> Property prop_fromNodeToFinal (N t) = forAll (regionInside (subtreeRegion $ snd t)) $ \r -> do- let final@(finalPath, finalSubtree) = fromNodeToFinal r t+ let final@(_, finalSubtree) = fromNodeToFinal r t finalRegion = subtreeRegion finalSubtree whenFail (do putStrLn $ "final = " ++ show final putStrLn $ "final reg = " ++ show finalRegion
+ src/library/Yi/Tab.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Yi.Tab+ (+ Tab,+ TabRef,+ tabWindowsA,+ tabLayoutManagerA,+ tabDividerPositionA,+ tkey,+ tabMiniWindows,+ tabFocus,+ forceTab,+ mapWindows,+ tabLayout,+ tabFoldl,+ makeTab,+ makeTab1,+ ) where++import qualified Prelude+import Yi.Prelude+import qualified Data.Binary as Binary+import Data.Accessor.Basic+import qualified Data.List.PointedList as PL++import Yi.Buffer.Basic(WindowRef)+import Yi.Layout+import Yi.Window++type TabRef = Int++-- | A tab, containing a collection of windows.+data Tab = Tab {+ tkey :: !TabRef, -- ^ For UI sync; fixes #304+ tabWindows :: !(PL.PointedList Window), -- ^ Visible windows+ tabLayout :: !(Layout WindowRef), -- ^ Current layout. Invariant: must be the layout generated by 'tabLayoutManager', up to changing the 'divPos's.+ tabLayoutManager :: !AnyLayoutManager -- ^ layout manager (for regenerating the layout when we add/remove windows)+ }+ deriving Typeable++tabFocus :: Tab -> Window+tabFocus = PL.focus . tabWindows++-- | Returns a list of all mini windows associated with the given tab+tabMiniWindows :: Tab -> [Window]+tabMiniWindows = Prelude.filter isMini . toList . tabWindows++-- | Accessor for the windows. If the windows (but not the focus) have changed when setting, then a relayout will be triggered to preserve the internal invariant.+tabWindowsA :: Accessor Tab (PL.PointedList Window)+tabWindowsA = fromSetGet setter getter+ where+ setter ws t = relayoutIf (toList ws /= toList (tabWindows t)) (t { tabWindows = ws})+ getter = tabWindows++-- | Accessor for the layout manager. When setting, will trigger a relayout if the layout manager has changed.+tabLayoutManagerA :: Accessor Tab AnyLayoutManager+tabLayoutManagerA = fromSetGet setter getter+ where+ setter lm t = relayoutIf (lm /= tabLayoutManager t) (t { tabLayoutManager = lm })+ getter = tabLayoutManager++-- | Gets / sets the position of the divider with the given reference. The caller must ensure that the DividerRef is valid, otherwise an error will (might!) occur.+tabDividerPositionA :: DividerRef -> Accessor Tab DividerPosition+tabDividerPositionA ref = dividerPositionA ref . fromSetGet (\l t -> t { tabLayout = l}) tabLayout++relayoutIf :: Bool -> Tab -> Tab+relayoutIf False t = t+relayoutIf True t = relayout t++relayout :: Tab -> Tab+relayout t = t { tabLayout = buildLayout (tabWindows t) (tabLayoutManager t) (tabLayout t) }++instance Binary.Binary Tab where+ put (Tab tk ws _ _) = Binary.put tk >> Binary.put ws+ get = makeTab <$> Binary.get <*> Binary.get+++-- | Equality on tab identity (the 'tkey')+instance Eq Tab where+ (==) t1 t2 = tkey t1 == tkey t2++instance Show Tab where+ show t = "Tab " ++ show (tkey t)++-- | A specialised version of "fmap".+mapWindows :: (Window -> Window) -> Tab -> Tab+mapWindows f = modify tabWindowsA (fmap f)++-- | Forces all windows in the tab+forceTab :: Tab -> Tab+forceTab t = foldr seq t (t ^. tabWindowsA)++-- | Folds over the windows in the tab+tabFoldl :: (a -> Window -> a) -> a -> Tab -> a+tabFoldl f z t = foldl f z (t ^. tabWindowsA)++-- -- | Run the layout on the given tab, for the given aspect ratio+buildLayout :: PL.PointedList Window -> AnyLayoutManager -> Layout WindowRef -> Layout WindowRef+buildLayout ws m l = pureLayout m l . fmap wkey . Prelude.filter (not . isMini) . toList $ ws++-- | Make a tab from multiple windows+makeTab :: TabRef -> PL.PointedList Window -> Tab+makeTab key ws = Tab key ws (buildLayout ws initial initial) initial++-- | Make a tab from one window+makeTab1 :: TabRef -> Window -> Tab+makeTab1 key win = makeTab key (PL.singleton win)
src/library/Yi/Tag.hs view
@@ -31,19 +31,18 @@ import Data.Map (Map, fromList, lookup, keys) import Data.List.Split (splitOn) -import Data.Typeable import qualified Data.Trie as Trie+import Data.Binary+import Data.DeriveTH newtype Tags = Tags (Maybe TagTable) deriving Typeable instance Initializable Tags where initial = Tags Nothing - newtype TagsFileList = TagsFileList [FilePath] deriving Typeable instance Initializable TagsFileList where initial = TagsFileList ["tags"] - type Tag = String data TagTable = TagTable { tagFileName :: FilePath@@ -123,3 +122,15 @@ getTagsFileList = do TagsFileList fps <- getDynamic return fps++-- template haskell at the end to avoid 'not found' compilation errors+$(derives [makeBinary] [''Tags, ''TagTable, ''TagsFileList])++-- For GHC 7.0 with template-haskell 2.5 (at least on my computer - coconnor) the Binary instance+-- needs to be defined before the YiVariable instance. +--+-- GHC 7.1 does not appear to have this issue.+instance YiVariable Tags++instance YiVariable TagsFileList+
src/library/Yi/TextCompletion.hs view
@@ -32,11 +32,13 @@ -- Point -- beginning of the thing we try to complete [String] -- the list of all possible things we can complete to. -- (this seems very inefficient; but we use lazyness to our advantage)- deriving Typeable+ deriving (Typeable, Binary) -- TODO: put this in keymap state instead instance Initializable Completion where initial = Completion []++instance YiVariable Completion -- | Switch out of completion mode. resetComplete :: EditorM ()
src/library/Yi/UI/Common.hs view
@@ -4,6 +4,47 @@ import Yi.Editor +{- | Record presenting a frontend's interface.++The functions 'layout' and 'refresh' are both run by the editor's main loop, +in response to user actions and so on. Their relation is a little subtle, and+is discussed here:++ * to see some code, look at the function @refreshEditor@ in "Yi.Core". + This is the only place where 'layout' and 'refresh' are used.++ * the function 'layout' is responsible for updating the 'Editor' with the + width and height of the windows. Some frontends, such as Pango, need to+ modify their internal state to do this, and will consequently change + their display. This is expected. ++ * the function 'refresh' should cause the UI to update its display with + the information given in the 'Editor'.++ * the functionalities of 'layout' and 'refresh' overlap to some extent, in+ the sense that both may cause the frontend to update its display. The Yi core+ provides the following guarantees which the frontend may take advantage of:++ * in the main editor loop (i.e. in the @refreshEditor@ function), + 'layout' will be run (possibly multiple times) and then 'refresh' will+ be run. This guarantee will hold even in the case of threading (the+ function @refreshEditor@ will always be run atomically, using @MVar@s).++ * between the last run of 'layout' and the run of 'refresh', some changes+ may be made to the 'Editor'. However, the text, text attributes, and + (displayed) window region of all windows will remain the same. However,+ the cursor location may change.++ This guarantee allows frontends which calculate rendering of the text+ during the 'layout' stage to avoid recalculating the render again during+ 'refresh'. Pango is an example of such a frontend.++The Yi core provides no guarantee about the OS thread from which the functions+'layout' and 'refresh' are called from. In particular, subprocesses (e.g. compilation, +ghci) will run 'layout' and 'refresh' from new OS threads (see @startSubprocessWatchers@+in "Yi.Core"). The frontend must be preparaed for this: for instance, Gtk-based frontends+should wrap GUI updates in @postGUIAsync@.+-} data UI = UI { main :: IO () -- ^ Main loop , end :: Bool -> IO () -- ^ Clean up, and also terminate if given 'true'
src/library/Yi/UI/Pango.hs view
@@ -1,46 +1,44 @@-{-# LANGUAGE CPP, BangPatterns, ExistentialQuantification, DoRec,- ParallelListComp #-}+{-# LANGUAGE CPP, ExistentialQuantification, DoRec, TupleSections, NamedFieldPuns, ViewPatterns #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} -- Copyright (c) 2007, 2008 Jean-Philippe Bernardy -- | This module defines a user interface implemented using gtk2hs and -- pango for direct text rendering.--module Yi.UI.Pango (start, processEvent) where+module Yi.UI.Pango (start) where -import Prelude (filter, map, round, FilePath, (/))+import Prelude (catch, filter) -import Control.Concurrent (yield)-import Control.Monad (ap)-import Control.Monad.Reader (liftIO, when, MonadIO)+import Control.Concurrent import Data.Prototype import Data.IORef-import Data.List (drop, intercalate, nub, zip)+import Data.List (drop, intercalate, zip) import qualified Data.List.PointedList.Circular as PL import Data.Maybe import qualified Data.Map as M import qualified Data.Rope as Rope -import Graphics.UI.Gtk hiding (on, Region, Window, Action, Point, Style)+import Graphics.UI.Gtk hiding (Region, Window, Action, Point, Style, Modifier, on) import Graphics.UI.Gtk.Gdk.GC hiding (foreground)-import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events+import qualified Graphics.UI.Gtk.Gdk.EventM as EventM import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Gdk.GC as Gtk import System.Glib.GError -import Yi.Prelude+import Yi.Prelude hiding (on) import Yi.Buffer import Yi.Config-import qualified Yi.Editor as Editor-import Yi.Editor hiding (windows)+import Yi.Editor import Yi.Event import Yi.Keymap-import Yi.Monad+import Yi.Layout(DividerPosition, DividerRef) import Yi.Style+import Yi.Tab import Yi.Window import qualified Yi.UI.Common as Common+import Yi.UI.Pango.Layouts import Yi.UI.Pango.Utils import Yi.UI.TabBar import Yi.UI.Utils@@ -49,51 +47,81 @@ import Yi.UI.Pango.Gnome(watchSystemFont) #endif +-- We use IORefs in all of these datatypes for all fields which could+-- possibly change over time. This ensures that no 'UI', 'TabInfo',+-- 'WinInfo' will ever go out of date.+ data UI = UI { uiWindow :: Gtk.Window- , uiNotebook :: Notebook+ , uiNotebook :: SimpleNotebook , uiStatusbar :: Statusbar- , tabCache :: IORef [TabInfo]+ , tabCache :: IORef TabCache , uiActionCh :: Action -> IO () , uiConfig :: UIConfig , uiFont :: IORef FontDescription+ , uiInput :: IMContext } +type TabCache = PL.PointedList TabInfo++-- We don't need to know the order of the windows (the layout manages+-- that) so we might as well use a map+type WindowCache = M.Map WindowRef WinInfo+ data TabInfo = TabInfo- { coreTab :: PL.PointedList Window- , page :: VBox- , windowCache :: [WinInfo]+ { coreTabKey :: TabRef+ , layoutDisplay :: LayoutDisplay+ , miniwindowPage :: MiniwindowDisplay+ , tabWidget :: Widget+ , windowCache :: IORef WindowCache+ , fullTitle :: IORef String+ , abbrevTitle :: IORef String } instance Show TabInfo where- show t = show (coreTab t)+ show t = show (coreTabKey t) data WinInfo = WinInfo- { coreWin :: Window+ { coreWinKey :: WindowRef+ , coreWin :: IORef Window , shownTos :: IORef Point- , renderer :: IORef (ConnectId DrawingArea)- , winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))- , winLayout :: PangoLayout+ , lButtonPressed :: IORef Bool + , insertingMode :: IORef Bool+ , inFocus :: IORef Bool+ , winLayoutInfo :: MVar WinLayoutInfo , winMetrics :: FontMetrics , textview :: DrawingArea , modeline :: Label- , widget :: Box -- ^ Top-level widget for this window.+ , winWidget :: Widget -- ^ Top-level widget for this window. } +data WinLayoutInfo = WinLayoutInfo {+ winLayout :: !PangoLayout,+ tos :: !Point,+ bos :: !Point,+ bufEnd :: !Point,+ cur :: !Point,+ buffer :: !FBuffer,+ regex :: !(Maybe SearchExp)+ }+ instance Show WinInfo where- show w = show (coreWin w)+ show w = show (coreWinKey w) +instance Ord EventM.Modifier where+ x <= y = fromEnum x <= fromEnum y+ mkUI :: UI -> Common.UI mkUI ui = Common.dummyUI- { Common.main = main ui+ { Common.main = main , Common.end = const end , Common.suspend = windowIconify (uiWindow ui) , Common.refresh = refresh ui , Common.layout = doLayout ui- , Common.reloadProject = reloadProject ui+ , Common.reloadProject = const reloadProject } -updateFont :: UIConfig -> IORef FontDescription -> IORef [TabInfo] -> Statusbar+updateFont :: UIConfig -> IORef FontDescription -> IORef TabCache -> Statusbar -> FontDescription -> IO () updateFont cfg fontRef tc status font = do maybe (return ()) (fontDescriptionSetFamily font) (configFontName cfg)@@ -102,9 +130,9 @@ widgetModifyFont status (Just font) tcs <- readIORef tc forM_ tcs $ \tabinfo -> do- let wcs = windowCache tabinfo- forM_ wcs $ \wininfo -> do- layoutSetFontDescription (winLayout wininfo) (Just font)+ wcs <- readIORef (windowCache tabinfo)+ forM_ wcs $ \wininfo -> do+ withMVar (winLayoutInfo wininfo) $ \WinLayoutInfo{winLayout} -> layoutSetFontDescription winLayout (Just font) -- This will cause the textview to redraw widgetModifyFont (textview wininfo) (Just font) widgetModifyFont (modeline wininfo) (Just font)@@ -117,68 +145,44 @@ start cfg ch outCh ed = catchGError (startNoMsg cfg ch outCh ed) (\(GError _dom _code msg) -> fail msg) startNoMsg :: UIBoot-startNoMsg cfg ch outCh _ed = do+startNoMsg cfg ch outCh ed = do logPutStrLn "startNoMsg"- unsafeInitGUIForThreadedRTS-- win <- windowNew- windowSetDefaultSize win 900 700- windowSetTitle win "Yi"- ico <- loadIcon "yi+lambda-fat.32.png"- windowSetIcon win (Just ico)+ discard unsafeInitGUIForThreadedRTS - onKeyPress win (processEvent ch)+ win <- windowNew+ ico <- loadIcon "yi+lambda-fat-32.png"+ vb <- vBoxNew False 1 -- Top-level vbox+ + im <- imMulticontextNew+ imContextSetUsePreedit im False -- handler for preedit string not implemented + im `on` imContextCommit $ mapM_ (\k -> ch $ Event (KASCII k) []) -- Yi.Buffer.Misc.insertN for atomic input? + set win [ windowDefaultWidth := 700+ , windowDefaultHeight := 900+ , windowTitle := "Yi"+ , windowIcon := Just ico+ , containerChild := vb+ ]+ win `on` deleteEvent $ io $ mainQuit >> return True+ win `on` keyPressEvent $ handleKeypress ch im+ paned <- hPanedNew-- vb <- vBoxNew False 1 -- Top-level vbox-- -- Disable the left pane (file/module browser) until Shim/Scion discussion has- -- concluded. Shim causes crashes, but it's not worth fixing if we'll soon- -- replace it.-- {-- tabs' <- notebookNew- widgetSetSizeRequest tabs' 200 (-1)- notebookSetTabPos tabs' PosBottom- panedAdd1 paned tabs'-- -- Create the tree views for files and modules- (filesProject, modulesProject) <- loadProject =<< getCurrentDirectory-- filesStore <- treeStoreNew [filesProject]- modulesStore <- treeStoreNew [modulesProject]-- filesTree <- projectTreeNew (outCh . singleton) filesStore- modulesTree <- projectTreeNew (outCh . singleton) modulesStore-- scrlProject <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport scrlProject filesTree- scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic- notebookAppendPage tabs scrlProject "Project"-- scrlModules <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport scrlModules modulesTree- scrolledWindowSetPolicy scrlModules PolicyAutomatic PolicyAutomatic- notebookAppendPage tabs scrlModules "Modules"- -}-- tabs <- notebookNew- panedAdd2 paned tabs-- set win [ containerChild := vb ]- onDestroy win mainQuit+ tabs <- simpleNotebookNew+ panedAdd2 paned (baseWidget tabs) status <- statusbarNew- statusbarGetContextId status "global"+ -- statusbarGetContextId status "global" - set vb [ containerChild := paned,- containerChild := status,- boxChildPacking status := PackNatural ]+ set vb [ containerChild := paned+ , containerChild := status+ , boxChildPacking status := PackNatural+ ] fontRef <- newIORef undefined- tc <- newIORef [] + let actionCh = outCh . singleton+ tc <- newIORef =<< newCache ed actionCh+ #ifdef GNOME_ENABLED let watchFont = watchSystemFont #else@@ -187,286 +191,143 @@ watchFont $ updateFont (configUI cfg) fontRef tc status -- use our magic threads thingy (http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/)- timeoutAddFull (yield >> return True) priorityDefaultIdle 50+ discard $ timeoutAddFull (yield >> return True) priorityDefaultIdle 50 widgetShowAll win - let ui = UI win tabs status tc (outCh . singleton) (configUI cfg) fontRef+ let ui = UI win tabs status tc actionCh (configUI cfg) fontRef im -- Keep the current tab focus up to date let move n pl = maybe pl id (PL.move n pl) runAction = uiActionCh ui . makeAction -- why does this cause a hang without postGUIAsync?- onSwitchPage (uiNotebook ui) $ \n -> postGUIAsync $+ simpleNotebookOnSwitchPage (uiNotebook ui) $ \n -> postGUIAsync $ runAction (modA tabsA (move n) :: EditorM ()) return (mkUI ui) -main :: UI -> IO ()-main _ui =- do logPutStrLn "GTK main loop running"- mainGUI -processEvent :: (Event -> IO ()) -> Gdk.Events.Event -> IO Bool-processEvent ch ev = do- -- logPutStrLn $ "Gtk.Event: " ++ show ev- -- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)- case gtkToYiEvent ev of- Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev- Just e -> ch e- return True--gtkToYiEvent :: Gdk.Events.Event -> Maybe Event-gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = key, Gdk.Events.eventModifier = evModifier, Gdk.Events.eventKeyChar = char})- = fmap (\k -> Event k $ (nub $ (if isShift then filter (/= MShift) else id) $ concatMap modif evModifier)) key'- where (key',isShift) =- case char of- Just c -> (Just $ KASCII c, True)- Nothing -> (M.lookup key keyTable, False)- modif Gdk.Events.Control = [MCtrl]- modif Gdk.Events.Alt = [MMeta]- modif Gdk.Events.Shift = [MShift]- modif _ = []-gtkToYiEvent _ = Nothing---- | Map GTK long names to Keys-keyTable :: M.Map String Key-keyTable = M.fromList- [("Down", KDown)- ,("Up", KUp)- ,("Left", KLeft)- ,("Right", KRight)- ,("Home", KHome)- ,("End", KEnd)- ,("BackSpace", KBS)- ,("Delete", KDel)- ,("Page_Up", KPageUp)- ,("Page_Down", KPageDown)- ,("Insert", KIns)- ,("Escape", KEsc)- ,("Return", KEnter)- ,("Tab", KTab)- ,("ISO_Left_Tab", KTab)- ]+main :: IO ()+main = logPutStrLn "GTK main loop running" >> mainGUI -- | Clean up and go home end :: IO () end = mainQuit -syncTabs :: Editor -> UI -> [(PL.PointedList Window, Bool)] -> [TabInfo] -> IO [TabInfo]-syncTabs e ui (tfocused@(t,focused):ts) (c:cs)- | t == coreTab c =- do when focused $ setTabFocus ui c- let wCache = windowCache c- (:) <$> syncTab e ui c t wCache <*> syncTabs e ui ts cs- | t `elem` map coreTab cs =- do removeTab ui c- syncTabs e ui (tfocused:ts) cs- | otherwise =- do c' <- insertTabBefore e ui t c- when focused $ setTabFocus ui c'- return (c':) `ap` syncTabs e ui ts (c:cs)-syncTabs e ui ts [] = mapM (\(t,focused) -> do c' <- insertTab e ui t- when focused $ setTabFocus ui c'- return c')- ts-syncTabs _ ui [] cs = mapM_ (removeTab ui) cs >> return []+-- | Modify GUI and the 'TabCache' to reflect information in 'Editor'.+updateCache :: UI -> Editor -> IO ()+updateCache ui e = do+ cache <- readRef $ tabCache ui+ -- convert to a map for convenient lookups+ let cacheMap = mapFromFoldable . fmap (\t -> (coreTabKey t, t)) $ cache -syncTab :: Editor -> UI -> TabInfo -> PL.PointedList Window -> [WinInfo] -> IO TabInfo-syncTab e ui tab ws cache = do- wCache <- syncWindows e ui tab (toList $ PL.withFocus ws) cache- return tab { windowCache = wCache }+ -- build the new cache+ cache' <- forM (e ^. tabsA) $ \tab ->+ case M.lookup (tkey tab) cacheMap of+ Just t -> updateTabInfo e ui tab t >> return t+ Nothing -> newTab e ui tab --- | Synchronize the windows displayed by GTK with the status of windows in the Core.-syncWindows :: Editor -> UI -> TabInfo -> [(Window, Bool)] -- ^ windows paired with their "isFocused" state.- -> [WinInfo] -> IO [WinInfo]-syncWindows e ui tab (wfocused@(w,focused):ws) (c:cs)- | w == coreWin c =- do when focused $ setWindowFocus e ui tab c- (c { coreWin = w}:) <$> syncWindows e ui tab ws cs- | w `elem` map coreWin cs =- removeWindow ui tab c >> syncWindows e ui tab (wfocused:ws) cs- | otherwise = do- c' <- insertWindowBefore e ui tab w c- when focused (setWindowFocus e ui tab c')- return (c':) `ap` syncWindows e ui tab ws (c:cs)-syncWindows e ui tab ws [] = mapM (\(w,focused) -> do c' <- insertWindowAtEnd e ui tab w- when focused (setWindowFocus e ui tab c')- return c')- ws-syncWindows _ ui tab [] cs = mapM_ (removeWindow ui tab) cs >> return []+ -- store the new cache+ writeRef (tabCache ui) cache' -setTabFocus :: UI -> TabInfo -> IO ()-setTabFocus ui t = do- p <- notebookPageNum (uiNotebook ui) (page t)- case p of- Just n -> update (uiNotebook ui) notebookPage n- Nothing -> return ()+ -- update the GUI+ simpleNotebookSet (uiNotebook ui) =<< forM cache' (\t -> (tabWidget t,) <$> readIORef (abbrevTitle t)) --- Only set an attribute if has actually changed.--- This makes setting window titles much faster.-update :: forall o a. (Eq a) => o -> ReadWriteAttr o a a -> a -> IO ()-update w attr val = do oldVal <- get w attr- when (val /= oldVal) $ set w [attr := val] -setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()-setWindowFocus e ui t w = do- let bufferName = shortIdentString (commonNamePrefix e) $ findBufferWith (bufkey $ coreWin w) e- ml = askBuffer (coreWin w) (findBufferWith (bufkey $ coreWin w) e) $ getModeLine (commonNamePrefix e)-- update (textview w) widgetIsFocus True- update (modeline w) labelText ml- update (uiWindow ui) windowTitle $ bufferName ++ " - Yi"- update (uiNotebook ui) (notebookChildTabLabel (page t)) (tabAbbrevTitle bufferName)--removeTab :: UI -> TabInfo -> IO ()-removeTab ui t = do- p <- notebookPageNum (uiNotebook ui) (page t)- case p of- Just n -> notebookRemovePage (uiNotebook ui) n- Nothing -> return ()--removeWindow :: UI -> TabInfo -> WinInfo -> IO ()-removeWindow _ tab win = do- containerRemove (page tab) (widget win)--getWinInfo :: WindowRef -> [TabInfo] -> (Int, Int, WinInfo)-getWinInfo ref tabInfos =- head [ (tabIx, winIx, winInfo)- | (tabIx, tabInfo) <- zip [0..] tabInfos- , (winIx, winInfo) <- zip [0..] (windowCache tabInfo)- , ref == (wkey . coreWin) winInfo- ]--handleClick :: UI -> WindowRef -> Gdk.Events.Event -> IO Bool-handleClick ui ref event = do- (_tabIdx,winIdx,w) <- getWinInfo ref <$> readIORef (tabCache ui)+-- | Modify GUI and given 'TabInfo' to reflect information in 'Tab'.+updateTabInfo :: Editor -> UI -> Tab -> TabInfo -> IO ()+updateTabInfo e ui tab tabInfo = do+ -- update the window cache+ wCacheOld <- readIORef (windowCache tabInfo)+ wCacheNew <- mapFromFoldable <$> (forM (tab ^. tabWindowsA) $ \w ->+ case M.lookup (wkey w) wCacheOld of+ Just wInfo -> updateWindow e ui w wInfo >> return (wkey w, wInfo)+ Nothing -> (wkey w,) <$> newWindow e ui w)+ writeIORef (windowCache tabInfo) wCacheNew - logPutStrLn $ "Click: " ++ show (Gdk.Events.eventX event,- Gdk.Events.eventY event,- Gdk.Events.eventClick event)+ -- TODO update renderer, etc? - -- retrieve the clicked offset.- (_,layoutIndex,_) <- io $ layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)- tos <- readRef (shownTos w)- let p1 = tos + fromIntegral layoutIndex+ let lookupWin w = wCacheNew M.! w - -- maybe focus the window- logPutStrLn $ "Clicked inside window: " ++ show w+ -- set layout+ layoutDisplaySet (layoutDisplay tabInfo) . fmap (winWidget . lookupWin) . tabLayout $ tab - let focusWindow = do- -- TODO: check that tabIdx is the focus?- modA windowsA (fromJust . PL.move winIdx)+ -- set minibox+ miniwindowDisplaySet (miniwindowPage tabInfo) . fmap (winWidget . lookupWin . wkey) . tabMiniWindows $ tab - case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of- (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do- writeRef (winMotionSignal w) =<< Just <$> onMotionNotify (textview w) False (handleMove ui w p1)+ -- set focus+ setWindowFocus e ui tabInfo . lookupWin . wkey . tabFocus $ tab - _ -> do maybe (return ()) signalDisconnect =<< readRef (winMotionSignal w)- writeRef (winMotionSignal w) Nothing- +updateWindow :: Editor -> UI -> Window -> WinInfo -> IO ()+updateWindow e _ui win wInfo = do+ writeIORef (inFocus wInfo) False -- see also 'setWindowFocus'+ writeIORef (coreWin wInfo) win+ writeIORef (insertingMode wInfo) (askBuffer win (findBufferWith (bufkey win) e) $ getA insertingA) - let runAction = uiActionCh ui . makeAction- case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of- (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> runAction $ do- b <- gets $ (bkey . findBufferWith (bufkey $ coreWin w))- focusWindow- withGivenBufferAndWindow0 (coreWin w) b $ do- moveTo p1- setVisibleSelection False- (Gdk.Events.SingleClick, _) -> runAction focusWindow- (Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do- disp <- widgetGetDisplay (textview w)- cb <- clipboardGetForDisplay disp selectionPrimary- let cbHandler Nothing = return ()- cbHandler (Just txt) = runAction $ do- b <- gets $ (bkey . findBufferWith (bufkey $ coreWin w))- withGivenBufferAndWindow0 (coreWin w) b $ do- pointB >>= setSelectionMarkPointB- moveTo p1- insertN txt- clipboardRequestText cb cbHandler- _ -> return ()+setWindowFocus :: Editor -> UI -> TabInfo -> WinInfo -> IO ()+setWindowFocus e ui t w = do+ win <- readIORef (coreWin w)+ let bufferName = shortIdentString (commonNamePrefix e) $ findBufferWith (bufkey win) e+ ml = askBuffer win (findBufferWith (bufkey win) e) $ getModeLine (commonNamePrefix e)+ im = uiInput ui - return True+ writeIORef (inFocus w) True -- see also 'updateWindow'+ update (textview w) widgetIsFocus True+ update (modeline w) labelText ml+ writeIORef (fullTitle t) bufferName+ writeIORef (abbrevTitle t) (tabAbbrevTitle bufferName)+ drawW <- catch (fmap Just $ widgetGetDrawWindow $ textview w) (const (return Nothing))+ imContextSetClientWindow im drawW+ imContextFocusIn im -handleScroll :: UI -> WindowRef -> Gdk.Events.Event -> IO Bool-handleScroll ui _ event = do- let editorAction = do - withBuffer0 $ vimScrollB $ case Gdk.Events.eventDirection event of- Gdk.Events.ScrollUp -> (-1)- Gdk.Events.ScrollDown -> 1- _ -> 0 -- Left/right scrolling not supported+getWinInfo :: UI -> WindowRef -> IO WinInfo+getWinInfo ui ref =+ let tabLoop [] = error "Yi.UI.Pango.getWinInfo: window not found"+ tabLoop (t:ts) = do+ wCache <- readIORef (windowCache t)+ case M.lookup ref wCache of+ Just w -> return w+ Nothing -> tabLoop ts+ in readIORef (tabCache ui) >>= (tabLoop . toList) - uiActionCh ui (makeAction editorAction)- return True+-- | Make the cache from the editor and the action channel+newCache :: Editor -> (Action -> IO ()) -> IO TabCache+newCache e actionCh = mapM (mkDummyTab actionCh) (e ^. tabsA) -handleMove :: UI -> WinInfo -> Point -> Gdk.Events.Event -> IO Bool-handleMove ui w p0 event = do- logPutStrLn $ "Motion: " ++ show (Gdk.Events.eventX event, Gdk.Events.eventY event)+-- | Make a new tab, and populate it+newTab :: Editor -> UI -> Tab -> IO TabInfo+newTab e ui tab = do+ t <- mkDummyTab (uiActionCh ui) tab+ updateTabInfo e ui tab t+ return t - -- retrieve the clicked offset.- (_,layoutIndex,_) <- layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)- tos <- readRef (shownTos w)- let p1 = tos + fromIntegral layoutIndex+-- | Make a minimal new tab, without any windows. This is just for bootstrapping the UI; 'newTab' should normally be called instead.+mkDummyTab :: (Action -> IO ()) -> Tab -> IO TabInfo+mkDummyTab actionCh tab = do+ ws <- newIORef M.empty+ ld <- layoutDisplayNew+ layoutDisplayOnDividerMove ld (handleDividerMove actionCh)+ mwp <- miniwindowDisplayNew+ tw <- vBoxNew False 0+ set tw [containerChild := baseWidget ld,+ containerChild := baseWidget mwp,+ boxChildPacking (baseWidget ld) := PackGrow,+ boxChildPacking (baseWidget mwp) := PackNatural]+ ftRef <- newIORef ""+ atRef <- newIORef ""+ return (TabInfo (tkey tab) ld mwp (toWidget tw) ws ftRef atRef) - let editorAction = do- txt <- withBuffer0 $ do- if p0 /= p1 - then Just <$> do- m <- selMark <$> askMarks- setMarkPointB m p0- moveTo p1- setVisibleSelection True- readRegionB =<< getSelectRegionB- else return Nothing- maybe (return ()) setRegE txt-- uiActionCh ui (makeAction editorAction)- -- drawWindowGetPointer (textview w) -- be ready for next message.-- -- Relies on uiActionCh being synchronous- selection <- newIORef ""- let yiAction = do- txt <- withEditor (withBuffer0 (readRegionB =<< getSelectRegionB))- :: YiM String- liftIO $ writeIORef selection txt- uiActionCh ui (makeAction yiAction)- txt <- readIORef selection-- disp <- widgetGetDisplay (textview w)- cb <- clipboardGetForDisplay disp selectionPrimary- clipboardSetWithData cb [(targetString,0)]- (\0 -> selectionDataSetText txt >> return ()) (return ())-- return True--handleConfigure :: UI -> WindowRef -> Gdk.Events.Event -> IO Bool-handleConfigure ui _ref _ev = do- -- trigger a layout- -- why does this cause a hang without postGUIAsync?- postGUIAsync $ uiActionCh ui (makeAction (return () :: EditorM ()))- return False -- allow event to be propagated---- | Make a new tab.-newTab :: Editor -> UI -> VBox -> PL.PointedList Window -> IO TabInfo-newTab e ui vb ws = do- let t' = TabInfo { coreTab = ws- , page = vb- , windowCache = []- }- cache <- syncWindows e ui t' (toList $ PL.withFocus ws) []- return t' { windowCache = cache }- -- | Make a new window.-newWindow :: Editor -> UI -> Window -> FBuffer -> IO WinInfo-newWindow e ui w b = do+newWindow :: Editor -> UI -> Window -> IO WinInfo+newWindow e ui w = do+ let b = findBufferWith (bufkey w) e f <- readIORef (uiFont ui) ml <- labelNew Nothing widgetModifyFont ml (Just f) set ml [ miscXalign := 0.01 ] -- so the text is left-justified.+ widgetSetSizeRequest ml 0 (-1) -- allow the modeline to be covered up, horizontally v <- drawingAreaNew widgetModifyFont v (Just f)@@ -496,115 +357,83 @@ boxChildPacking ml := PackNatural] return (castToBox vb) - sig <- newIORef =<< (v `onExpose` render e ui b (wkey w)) tosRef <- newIORef (askBuffer w b (getMarkPointB =<< fromMark <$> askMarks)) context <- widgetCreatePangoContext v layout <- layoutEmpty context+ layoutRef <- newMVar (WinLayoutInfo layout 0 0 0 0 (findBufferWith (bufkey w) e) Nothing) language <- contextGetLanguage context metrics <- contextGetMetrics context f language- motionSig <- newIORef Nothing+ ifLButton <- newIORef False+ imode <- newIORef False+ focused <- newIORef False+ winRef <- newIORef w layoutSetFontDescription layout (Just f) layoutSetText layout "" -- stops layoutGetText crashing (as of gtk2hs 0.10.1) - let win = WinInfo { coreWin = w- , winLayout = layout+ let ref = wkey w+ win = WinInfo { coreWinKey = ref+ , coreWin = winRef+ , winLayoutInfo = layoutRef , winMetrics = metrics- , winMotionSignal = motionSig , textview = v , modeline = ml- , widget = box- , renderer = sig+ , winWidget = toWidget box , shownTos = tosRef+ , lButtonPressed = ifLButton+ , insertingMode = imode+ , inFocus = focused }+ updateWindow e ui w win + v `on` buttonPressEvent $ handleButtonClick ui ref+ v `on` buttonReleaseEvent $ handleButtonRelease ui win+ v `on` scrollEvent $ handleScroll ui win+ v `on` configureEvent $ handleConfigure ui -- todo: allocate event rather than configure?+ v `on` motionNotifyEvent $ handleMove ui win+ discard $ v `onExpose` render ui win+ -- also redraw when the window receives/loses focus+ (uiWindow ui) `on` focusInEvent $ io (widgetQueueDraw v) >> return False + (uiWindow ui) `on` focusOutEvent $ io (widgetQueueDraw v) >> return False + -- todo: consider adding an 'isDirty' flag to WinLayoutInfo,+ -- so that we don't have to recompute the Attributes when focus changes. return win -insertTabBefore :: Editor -> UI -> PL.PointedList Window -> TabInfo -> IO TabInfo-insertTabBefore e ui ws c = do- Just p <- notebookPageNum (uiNotebook ui) (page c)- vb <- vBoxNew False 1- notebookInsertPage (uiNotebook ui) vb "" p- widgetShowAll $ vb- t <- newTab e ui vb ws- return t--insertTab :: Editor -> UI -> PL.PointedList Window -> IO TabInfo-insertTab e ui ws = do- vb <- vBoxNew False 1- notebookAppendPage (uiNotebook ui) vb ""- widgetShowAll $ vb- t <- newTab e ui vb ws- return t--insertWindowBefore :: Editor -> UI -> TabInfo -> Window -> WinInfo -> IO WinInfo-insertWindowBefore e ui tab w _c = insertWindow e ui tab w--insertWindowAtEnd :: Editor -> UI -> TabInfo -> Window -> IO WinInfo-insertWindowAtEnd e ui tab w = insertWindow e ui tab w--insertWindow :: Editor -> UI -> TabInfo -> Window -> IO WinInfo-insertWindow e ui tab win = do- let buf = findBufferWith (bufkey win) e- liftIO $ do w <- newWindow e ui win buf-- set (page tab) $ - [ containerChild := widget w- , boxChildPacking (widget w) :=- if isMini (coreWin w)- then PackNatural- else PackGrow- ]-- let ref = (wkey . coreWin) w- textview w `onButtonRelease` handleClick ui ref- textview w `onButtonPress` handleClick ui ref- textview w `onScroll` handleScroll ui ref- textview w `onConfigure` handleConfigure ui ref- widgetShowAll (widget w)-- return w--updateCache :: UI -> Editor -> IO ()-updateCache ui e = do- let tabs = e ^. tabsA- cache <- readRef $ tabCache ui- cache' <- syncTabs e ui (toList $ PL.withFocus tabs) cache- writeRef (tabCache ui) cache'- refresh :: UI -> Editor -> IO () refresh ui e = do- contextId <- statusbarGetContextId (uiStatusbar ui) "global"- statusbarPop (uiStatusbar ui) contextId- statusbarPush (uiStatusbar ui) contextId $ intercalate " " $ statusLine e+ postGUIAsync $ do+ contextId <- statusbarGetContextId (uiStatusbar ui) "global"+ statusbarPop (uiStatusbar ui) contextId+ discard $ statusbarPush (uiStatusbar ui) contextId $ intercalate " " $ statusLine e updateCache ui e -- The cursor may have changed since doLayout cache <- readRef $ tabCache ui forM_ cache $ \t -> do- forM_ (windowCache t) $ \w -> do- let b = findBufferWith (bufkey (coreWin w)) e- -- when (not $ null $ b ^. pendingUpdatesA) $- do- sig <- readIORef (renderer w)- signalDisconnect sig- writeRef (renderer w) =<< (textview w `onExpose` render e ui b (wkey (coreWin w)))- widgetQueueDraw (textview w)+ wCache <- readIORef (windowCache t)+ forM_ wCache $ \w -> do+ updateWinInfoForRendering e ui w+ widgetQueueDraw (textview w) -render :: Editor -> UI -> FBuffer -> WindowRef -> t -> IO Bool-render e ui b ref _ev = do- (_,_,w) <- getWinInfo ref <$> readIORef (tabCache ui)- let win = coreWin w- let tos = max 0 (regionStart (winRegion win))- let bos = regionEnd (winRegion win)- let (cur, _) = runBuffer win b pointB+{- | Record all the information we need for rendering. - writeRef (shownTos w) tos- drawWindow <- widgetGetDrawWindow $ textview w+This information is kept in an MVar so that the PangoLayout and tos/bos/buffer are in sync.+-} +updateWinInfoForRendering :: Editor -> UI -> WinInfo -> IO ()+updateWinInfoForRendering e _ui w = modifyMVar_ (winLayoutInfo w) $ \wli -> do+ win <- readIORef (coreWin w)+ return $! wli{buffer=findBufferWith (bufkey win) e,regex=currentRegex e}++-- | Tell the 'PangoLayout' what colours to draw, and draw the 'PangoLayout' and the cursor onto the screen+render :: UI -> WinInfo -> t -> IO Bool+render ui w _event = withMVar (winLayoutInfo w) $ \WinLayoutInfo{winLayout=layout,tos,bos,cur,buffer=b,regex} -> do+ -- read the information+ win <- readIORef (coreWin w)+ -- add color attributes.- let picture = askBuffer (coreWin w) b $ attributesPictureAndSelB sty (currentRegex e) (mkRegion tos bos)+ let picture = askBuffer win b $ attributesPictureAndSelB sty regex (mkRegion tos bos) sty = extractValue $ configTheme (uiConfig ui)- strokes = [(start',s,end') | ((start', s), end') <- zip picture (drop 1 (map fst picture) ++ [bos]),+ strokes = [(start',s,end') | ((start', s), end') <- zip picture (drop 1 (fmap fst picture) ++ [bos]), s /= emptyAttributes] rel p = fromIntegral (p - tos) allAttrs = concat $ do@@ -615,22 +444,45 @@ , AttrUnderline (rel p1) (rel p2) (if udrl then UnderlineSingle else UnderlineNone) , AttrWeight (rel p1) (rel p2) (if bd then WeightBold else WeightNormal) ]- layout = winLayout w layoutSetAttributes layout allAttrs - (PangoRectangle curx cury curw curh, _) <- layoutGetCursorPos layout (rel cur)- PangoRectangle chx chy chw chh <- layoutIndexToPos layout (rel cur)-+ drawWindow <- widgetGetDrawWindow $ textview w gc <- gcNew drawWindow- drawLayout drawWindow gc 0 0 layout - -- paint the cursor - gcSetValues gc (newGCValues { Gtk.foreground = mkCol True $ Yi.Style.foreground $ baseAttributes $ configStyle $ uiConfig ui })- if askBuffer (coreWin w) b $ getA insertingA- then do drawLine drawWindow gc (round curx, round cury) (round $ curx + curw, round $ cury + curh) - else do drawRectangle drawWindow gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)+ -- see Note [PangoLayout width]+ -- draw the layout+ drawLayout drawWindow gc 1 0 layout + -- calculate the cursor position+ im <- readIORef (insertingMode w)++ -- check focus, and decide whether we want a wide cursor+ bufferFocused <- readIORef (inFocus w)+ uiFocused <- Gtk.windowHasToplevelFocus (uiWindow ui)+ let focused = bufferFocused && uiFocused+ wideCursor = + case configCursorStyle (uiConfig ui) of+ AlwaysFat -> True+ NeverFat -> False+ FatWhenFocused -> focused+ FatWhenFocusedAndInserting -> focused && im+ ++ (PangoRectangle (succ -> curX) curY curW curH, _) <- layoutGetCursorPos layout (rel cur)+ -- tell the input method+ imContextSetCursorLocation (uiInput ui) (Rectangle (round curX) (round curY) (round curW) (round curH))+ -- paint the cursor+ gcSetValues gc (newGCValues { Gtk.foreground = mkCol True $ Yi.Style.foreground $ baseAttributes $ configStyle $ uiConfig ui,+ Gtk.lineWidth = if wideCursor then 2 else 1 })+ -- tell the renderer+ if im + then -- if we are inserting, we just want a line+ drawLine drawWindow gc (round curX, round curY) (round $ curX + curW, round $ curY + curH)+ else do -- if we aren't inserting, we want a rectangle around the current character+ PangoRectangle (succ -> chx) chy chw chh <- layoutIndexToPos layout (rel cur)+ drawRectangle drawWindow gc False (round chx) (round chy) (if chw > 0 then round chw else 8) (round chh)+ return True doLayout :: UI -> Editor -> IO Editor@@ -638,58 +490,81 @@ updateCache ui e tabs <- readRef $ tabCache ui f <- readRef (uiFont ui)- heights <- concat <$> mapM (getHeightsInTab ui f e) tabs- let e' = (tabsA ^: fmap (fmap updateWin)) e- updateWin w = case find (\(ref,_,_) -> (wkey w == ref)) heights of+ heights <- fold <$> mapM (getHeightsInTab ui f e) tabs+ let e' = (tabsA ^: fmap (mapWindows updateWin)) e+ updateWin w = case M.lookup (wkey w) heights of Nothing -> w- Just (_,h,rgn) -> w { height = h, winRegion = rgn }+ Just (h,rgn) -> w { height = h, winRegion = rgn } -- Don't leak references to old Windows let forceWin x w = height w `seq` winRegion w `seq` x- return $ (foldl . foldl) forceWin e' (e' ^. tabsA)+ return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA) -getHeightsInTab :: UI -> FontDescription -> Editor -> TabInfo -> IO [(WindowRef,Int,Region)]+getHeightsInTab :: UI -> FontDescription -> Editor -> TabInfo -> IO (M.Map WindowRef (Int,Region)) getHeightsInTab ui f e tab = do- forM (windowCache tab) $ \wi -> do+ wCache <- readIORef (windowCache tab)+ forM wCache $ \wi -> do (_, h) <- widgetGetSize $ textview wi+ win <- readIORef (coreWin wi) let metrics = winMetrics wi lineHeight = ascent metrics + descent metrics- let b0 = findBufferWith (bufkey (coreWin wi)) e+ let b0 = findBufferWith (bufkey win) e rgn <- shownRegion ui f wi b0- let ret= (wkey (coreWin wi), round $ fromIntegral h / lineHeight, rgn)+ let ret= (round $ fromIntegral h / lineHeight, rgn) return ret shownRegion :: UI -> FontDescription -> WinInfo -> FBuffer -> IO Region-shownRegion ui f w b = do- (tos, _, bos) <- updatePango ui f w b layout- return $ mkRegion tos bos- where layout = winLayout w+shownRegion ui f w b = modifyMVar (winLayoutInfo w) $ \wli -> do+ (tos, cur, bos, bufEnd) <- updatePango ui f w b (winLayout wli)+ return (wli{tos,cur=clampTo tos bos cur,bos,bufEnd}, mkRegion tos bos)+ where clampTo lo hi x = max lo (min hi x)+-- during scrolling, cur might not lie between tos and bos, so we clamp it to avoid Pango errors -updatePango :: UI -> FontDescription -> WinInfo -> FBuffer -> PangoLayout -> IO (Point, Point, Point)+{-+Note [PangoLayout width]+~~~~~~~~~~~~~~~~~~~~~~~~++We start rendering the PangoLayout one pixel from the left of the rendering area, which means a few +/-1 offsets in Pango rendering and point lookup code.+The reason for this is to support the "wide cursor", which is 2 pixels wide. If we started rendering the PangoLayout +directly from the left of the rendering area instead of at a 1-pixel offset, then the "wide cursor" would only be half-displayed+when the cursor is at the beginning of the line, and would then be a "thin cursor".++An alternative would be to special-case the wide cursor rendering at the beginning of the line, and draw it one pixel to+the right of where it "should" be. I haven't tried this out to see how it looks.++Reiner+-}++-- we update the regex and the buffer to avoid holding on to potential garbage.+-- These will be overwritten with correct values soon, in+-- updateWinInfoForRendering.+updatePango :: UI -> FontDescription -> WinInfo -> FBuffer -> PangoLayout -> IO (Point, Point, Point, Point) updatePango ui font w b layout = do- (width', height') <- widgetGetSize $ textview w+ (width_', height') <- widgetGetSize $ textview w+ let width' = max 0 (width_' - 1) -- see Note [PangoLayout width] oldFont <- layoutGetFontDescription layout oldFontStr <- maybe (return Nothing) (fmap Just . fontDescriptionToString) oldFont newFontStr <- Just <$> fontDescriptionToString font when (oldFontStr /= newFontStr) (layoutSetFontDescription layout (Just font)) - let win = coreWin w- [width'', height''] = map fromIntegral [width', height']+ win <- readIORef (coreWin w)+ let [width'', height''] = fmap fromIntegral [width', height'] metrics = winMetrics w lineHeight = ascent metrics + descent metrics winh = max 1 $ floor (height'' / lineHeight) - (tos, point, text) = askBuffer win b $ do+ (tos, size, point, text) = askBuffer win b $ do from <- getMarkPointB =<< fromMark <$> askMarks rope <- streamB Forward from p <- pointB+ bufEnd <- sizeB let content = fst $ Rope.splitAtLine winh rope -- allow BOS offset to be just after the last line let addNL = if Rope.countNewLines content == winh then id else (++"\n")- return (from, p, addNL $ Rope.toString content)+ return (from, bufEnd, p, addNL $ Rope.toString content) if configLineWrap $ uiConfig ui then do oldWidth <- layoutGetWidth layout@@ -702,10 +577,10 @@ when (oldText /= text) (layoutSetText layout text) (_, bosOffset, _) <- layoutXYToIndex layout width'' (fromIntegral winh * lineHeight - 1)- return (tos, point, tos + fromIntegral bosOffset + 1)+ return (tos, point, tos + fromIntegral bosOffset + 1, size) -reloadProject :: UI -> FilePath -> IO ()-reloadProject _ _ = return ()+reloadProject :: IO ()+reloadProject = return () mkCol :: Bool -- ^ is foreground? -> Yi.Style.Color -> Gtk.Color@@ -714,3 +589,218 @@ mkCol _ (RGB x y z) = Color (fromIntegral x * 256) (fromIntegral y * 256) (fromIntegral z * 256)++-- * GTK Event handlers++-- | Process GTK keypress if IM fails+handleKeypress :: (Event -> IO ()) -- ^ Event dispatcher (Yi.Core.dispatch)+ -> IMContext+ -> EventM EKey Bool+handleKeypress ch im = do+ gtkMods <- eventModifier+ gtkKey <- eventKeyVal+ ifIM <- imContextFilterKeypress im+ let char = keyToChar gtkKey+ modsWithShift = M.keys $ M.filter (`elem` gtkMods) modTable+ mods | isJust char = filter (/= MShift) modsWithShift+ | otherwise = modsWithShift+ key = case char of+ Just c -> Just $ KASCII c+ Nothing -> M.lookup (keyName gtkKey) keyTable+ + case (ifIM, key) of+ (True, _ ) -> return ()+ (_, Nothing) -> logPutStrLn $ "Event not translatable: " ++ show key+ (_, Just k ) -> io $ ch $ Event k mods+ return True++-- | Map GTK long names to Keys+keyTable :: M.Map String Key+keyTable = M.fromList+ [("Down", KDown)+ ,("Up", KUp)+ ,("Left", KLeft)+ ,("Right", KRight)+ ,("Home", KHome)+ ,("End", KEnd)+ ,("BackSpace", KBS)+ ,("Delete", KDel)+ ,("Page_Up", KPageUp)+ ,("Page_Down", KPageDown)+ ,("Insert", KIns)+ ,("Escape", KEsc)+ ,("Return", KEnter)+ ,("Tab", KTab)+ ,("ISO_Left_Tab", KTab)+ ]++-- | Map Yi modifiers to GTK +modTable :: M.Map Modifier EventM.Modifier+modTable = M.fromList+ [ (MShift, EventM.Shift )+ , (MCtrl, EventM.Control)+ , (MMeta, EventM.Alt )+ , (MSuper, EventM.Super )+ , (MHyper, EventM.Hyper )+ ]++-- | Same as Gtk.on, but discards the ConnectId+on :: object -> Signal object callback -> callback -> IO ()+on widget signal handler = discard $ Gtk.on widget signal handler++handleButtonClick :: UI -> WindowRef -> EventM EButton Bool+handleButtonClick ui ref = do+ (x, y) <- eventCoordinates+ click <- eventClick+ button <- eventButton+ io $ do+ w <- getWinInfo ui ref+ point <- pointToOffset (x, y) w+ + let focusWindow = focusWindowE ref+ runAction = uiActionCh ui . makeAction+ + runAction focusWindow+ case (click, button) of+ (SingleClick, LeftButton) -> do+ io $ writeIORef (lButtonPressed w) True+ win <- io $ readIORef (coreWin w)+ runAction $ do+ b <- gets $ bkey . findBufferWith (bufkey win)+ withGivenBufferAndWindow0 win b $ do+ m <- selMark <$> askMarks+ setMarkPointB m point+ moveTo point+ setVisibleSelection False+ _ -> return ()+ + return True++handleButtonRelease :: UI -> WinInfo -> EventM EButton Bool+handleButtonRelease ui w = do+ (x, y) <- eventCoordinates+ button <- eventButton+ io $ do+ point <- pointToOffset (x, y) w+ disp <- widgetGetDisplay $ textview w+ cb <- clipboardGetForDisplay disp selectionPrimary+ case button of+ MiddleButton -> pasteSelectionClipboard ui w point cb+ LeftButton -> setSelectionClipboard ui w cb >>+ writeIORef (lButtonPressed w) False+ _ -> return ()+ return True++handleScroll :: UI -> WinInfo -> EventM EScroll Bool+handleScroll ui w = do+ scrollDirection <- eventScrollDirection+ xy <- eventCoordinates+ io $ do+ ifPressed <- readIORef $ lButtonPressed w+ -- query new coordinates+ let editorAction = do+ withBuffer0 $ scrollB $ case scrollDirection of+ ScrollUp -> negate configAmount+ ScrollDown -> configAmount+ _ -> 0 -- Left/right scrolling not supported+ configAmount = configScrollWheelAmount $ uiConfig ui+ uiActionCh ui (makeAction editorAction)+ if ifPressed+ then selectArea ui w xy+ else return ()+ return True++handleConfigure :: UI -> EventM EConfigure Bool+handleConfigure ui = do+ -- trigger a layout+ -- why does this cause a hang without postGUIAsync?+ io $ postGUIAsync $ uiActionCh ui (makeAction (return () :: EditorM()))+ return False -- allow event to be propagated+ +handleMove :: UI -> WinInfo -> EventM EMotion Bool+handleMove ui w = eventCoordinates >>= (io . selectArea ui w) >>+ return True++handleDividerMove :: (Action -> IO ()) -> DividerRef -> DividerPosition -> IO ()+handleDividerMove actionCh ref pos = actionCh (makeAction (setDividerPosE ref pos))++-- | Convert point coordinates to offset in Yi window+pointToOffset :: (Double, Double) -> WinInfo -> IO Point+pointToOffset (x,y) w = withMVar (winLayoutInfo w) $ \WinLayoutInfo{winLayout,tos,bufEnd} -> do+ im <- readIORef (insertingMode w)+ (_, charOffsetX, extra) <- layoutXYToIndex winLayout (max 0 (x-1)) y -- see Note [PangoLayout width]+ return $ min bufEnd (tos + fromIntegral (charOffsetX + if im then extra else 0))++selectArea :: UI -> WinInfo -> (Double, Double) -> IO ()+selectArea ui w (x,y) = do+ p <- pointToOffset (x,y) w+ let editorAction = do+ txt <- withBuffer0 $ do+ moveTo p+ setVisibleSelection True+ readRegionB =<< getSelectRegionB+ setRegE txt+ + uiActionCh ui (makeAction editorAction)+ -- drawWindowGetPointer (textview w) -- be ready for next message.++pasteSelectionClipboard :: UI -> WinInfo -> Point -> Clipboard -> IO ()+pasteSelectionClipboard ui w p cb = do+ win <- io $ readIORef (coreWin w)+ let cbHandler Nothing = return ()+ cbHandler (Just txt) = uiActionCh ui $ makeAction $ do+ b <- gets $ bkey . findBufferWith (bufkey win)+ withGivenBufferAndWindow0 win b $ do+ pointB >>= setSelectionMarkPointB+ moveTo p+ insertN txt+ clipboardRequestText cb cbHandler++-- | Set selection clipboard contents to current selection+setSelectionClipboard :: UI -> WinInfo -> Clipboard -> IO ()+setSelectionClipboard ui _w cb = do+ -- Why uiActionCh doesn't allow returning values?+ selection <- newIORef ""+ let yiAction = do+ txt <- withEditor $ withBuffer0 $ readRegionB =<< getSelectRegionB :: YiM String+ io $ writeIORef selection txt+ uiActionCh ui $ makeAction yiAction+ txt <- readIORef selection+ + if (not . null) txt+ then clipboardSetText cb txt+ else return () ++++-- Some useful stuff from `startNoMsg`+--+-- Disable the left pane (file/module browser) until Shim/Scion discussion has+-- concluded. Shim causes crashes, but it's not worth fixing if we'll soon+-- replace it.++{-+tabs' <- notebookNew+widgetSetSizeRequest tabs' 200 (-1)+notebookSetTabPos tabs' PosBottom+panedAdd1 paned tabs'++-- Create the tree views for files and modules+(filesProject, modulesProject) <- loadProject =<< getCurrentDirectory++filesStore <- treeStoreNew [filesProject]+modulesStore <- treeStoreNew [modulesProject]++filesTree <- projectTreeNew (outCh . singleton) filesStore+modulesTree <- projectTreeNew (outCh . singleton) modulesStore++scrlProject <- scrolledWindowNew Nothing Nothing+scrolledWindowAddWithViewport scrlProject filesTree+scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic+notebookAppendPage tabs scrlProject "Project"++scrlModules <- scrolledWindowNew Nothing Nothing+scrolledWindowAddWithViewport scrlModules modulesTree+scrolledWindowSetPolicy scrlModules PolicyAutomatic PolicyAutomatic+notebookAppendPage tabs scrlModules "Modules"+-}
src/library/Yi/UI/Pango/Control.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -w #-} -- this module isn't finished, and there's heaps of warnings. ----------------------------------------------------------------------------- -- -- Module : Yi.UI.Pango.Control@@ -34,7 +35,7 @@ import Data.Maybe (maybe, fromJust) import Data.IORef-import Data.List (drop, zip, take, length)+import Data.List (nub, filter, drop, zip, take, length) import Data.Prototype import qualified Data.Rope as Rope import qualified Data.Map as Map@@ -42,6 +43,7 @@ import Yi.Core (startEditor, focusAllSyntax) import Yi.Buffer import Yi.Config+import Yi.Tab import Yi.Window as Yi import Yi.Editor import Yi.Event@@ -75,13 +77,12 @@ import Control.Monad.Reader (liftIO, ask, asks, MonadReader(..)) import Control.Monad.State (liftM, ap, get, put, modify) import Control.Monad.Writer (MonadIO(..))-import Control.Concurrent (newMVar, modifyMVar, MVar(..), newEmptyMVar, putMVar, readMVar, isEmptyMVar)+import Control.Concurrent (newMVar, modifyMVar, MVar, newEmptyMVar, putMVar, readMVar, isEmptyMVar) import Data.Typeable import qualified Data.List.PointedList as PL (insertRight, withFocus, PointedList(..), singleton) import Yi.Regex import System.FilePath import qualified Yi.UI.Common as Common-import Yi.UI.Pango (processEvent) data Control = Control { controlYi :: Yi@@ -95,7 +96,7 @@ -- } data TabInfo = TabInfo- { coreTab :: PL.PointedList Yi.Window+ { coreTab :: Tab -- , page :: VBox } @@ -220,14 +221,14 @@ cacheRef <- asks tabCache tabs <- liftIO $ readRef cacheRef heights <- concat <$> mapM (getHeightsInTab e) tabs- let e' = (tabsA ^: fmap (fmap updateWin)) e+ let e' = (tabsA ^: fmap (mapWindows updateWin)) e updateWin w = case find (\(ref,_,_) -> (wkey w == ref)) heights of Nothing -> w Just (_,h,rgn) -> w { height = h, winRegion = rgn } -- Don't leak references to old Windows let forceWin x w = height w `seq` winRegion w `seq` x- return $ (foldl . foldl) forceWin e' (e' ^. tabsA)+ return $ (foldl . tabFoldl) forceWin e' (e' ^. tabsA) getHeightsInTab :: Editor -> TabInfo -> ControlM [(WindowRef,Int,Region)] getHeightsInTab e tab = do@@ -243,7 +244,7 @@ let ret= (windowRef v, round $ fromIntegral h / lineHeight, rgn) return $ a ++ [ret] Nothing -> return a)- [] (coreTab tab)+ [] (coreTab tab ^. tabWindowsA) shownRegion :: Editor -> View -> FBuffer -> ControlM Region shownRegion e v b = do@@ -299,7 +300,7 @@ cache' <- syncTabs e (toList $ PL.withFocus tabs) cache liftIO $ writeRef cacheRef cache' -syncTabs :: Editor -> [(PL.PointedList Yi.Window, Bool)] -> [TabInfo] -> ControlM [TabInfo]+syncTabs :: Editor -> [(Tab, Bool)] -> [TabInfo] -> ControlM [TabInfo] syncTabs e (tfocused@(t,focused):ts) (c:cs) | t == coreTab c = do when focused $ setTabFocus c@@ -318,7 +319,7 @@ return c') ts syncTabs _ [] cs = mapM_ removeTab cs >> return [] -syncTab :: Editor -> TabInfo -> PL.PointedList Yi.Window -> ControlM TabInfo+syncTab :: Editor -> TabInfo -> Tab -> ControlM TabInfo syncTab e tab ws = do -- TODO Maybe do something here return tab@@ -356,13 +357,13 @@ return () -- | Make a new tab.-newTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo+newTab :: Editor -> Tab -> ControlM TabInfo newTab e ws = do let t' = TabInfo { coreTab = ws } -- cache <- syncWindows e t' (toList $ PL.withFocus ws) [] return t' -- { views = cache } -insertTabBefore :: Editor -> PL.PointedList Yi.Window -> TabInfo -> ControlM TabInfo+insertTabBefore :: Editor -> Tab -> TabInfo -> ControlM TabInfo insertTabBefore e ws c = do -- Just p <- notebookPageNum (uiNotebook ui) (page c) -- vb <- vBoxNew False 1@@ -371,7 +372,7 @@ t <- newTab e ws return t -insertTab :: Editor -> PL.PointedList Yi.Window -> ControlM TabInfo+insertTab :: Editor -> Tab -> ControlM TabInfo insertTab e ws = do -- vb <- vBoxNew False 1 -- notebookAppendPage (uiNotebook ui) vb ""@@ -575,7 +576,10 @@ tabsRef <- asks tabCache ts <- liftIO $ readRef tabsRef- liftIO $ writeRef tabsRef (TabInfo (PL.singleton newWindow):ts)+ -- TODO: the Tab idkey should be assigned using+ -- Yi.Editor.newRef. But we can't modify that here, since our+ -- access to 'Yi' is readonly.+ liftIO $ writeRef tabsRef (TabInfo (makeTab1 0 newWindow):ts) viewsRef <- asks views vs <- liftIO $ readRef viewsRef@@ -745,3 +749,45 @@ liftIO $ widgetQueueDraw (drawArea view) return True++processEvent :: (Event -> IO ()) -> Gdk.Events.Event -> IO Bool+processEvent ch ev = do+ -- logPutStrLn $ "Gtk.Event: " ++ show ev+ -- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)+ case gtkToYiEvent ev of+ Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev+ Just e -> ch e+ return True++gtkToYiEvent :: Gdk.Events.Event -> Maybe Event+gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = key, Gdk.Events.eventModifier = evModifier, Gdk.Events.eventKeyChar = char})+ = fmap (\k -> Event k $ (nub $ (if isShift then filter (/= MShift) else id) $ concatMap modif evModifier)) key'+ where (key',isShift) =+ case char of+ Just c -> (Just $ KASCII c, True)+ Nothing -> (Map.lookup key keyTable, False)+ modif Gdk.Events.Control = [MCtrl]+ modif Gdk.Events.Alt = [MMeta]+ modif Gdk.Events.Shift = [MShift]+ modif _ = []+gtkToYiEvent _ = Nothing++-- | Map GTK long names to Keys+keyTable :: Map.Map String Key+keyTable = Map.fromList+ [("Down", KDown)+ ,("Up", KUp)+ ,("Left", KLeft)+ ,("Right", KRight)+ ,("Home", KHome)+ ,("End", KEnd)+ ,("BackSpace", KBS)+ ,("Delete", KDel)+ ,("Page_Up", KPageUp)+ ,("Page_Down", KPageDown)+ ,("Insert", KIns)+ ,("Escape", KEsc)+ ,("Return", KEnter)+ ,("Tab", KTab)+ ,("ISO_Left_Tab", KTab)+ ]
+ src/library/Yi/UI/Pango/Layouts.hs view
@@ -0,0 +1,392 @@+{- |+Provides abstract controls which implement 'Yi.Layout.Layout's and which manage the minibuffer.++The implementation strategy is to first construct the layout managers @WeightedStack@ (implementing the 'Stack' constructor) and @SlidingPair@ (implementing the 'Pair' constructor), and then construct 'LayoutDisplay' as a tree of these, mirroring the structure of 'Layout'.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving, ViewPatterns, TupleSections #-}++module Yi.UI.Pango.Layouts (+ -- * Getting the underlying widget+ WidgetLike(..),+ -- * Window layout+ LayoutDisplay,+ layoutDisplayNew,+ layoutDisplaySet,+ layoutDisplayOnDividerMove,+ -- * Miniwindow layout+ MiniwindowDisplay,+ miniwindowDisplayNew,+ miniwindowDisplaySet,+ -- * Tabs+ SimpleNotebook,+ simpleNotebookNew,+ simpleNotebookSet, -- incorporates label names, removeTab, insertTabBefore, insertTab+ simpleNotebookOnSwitchPage,+ -- * Utils+ update,+ ) where+++import Control.Monad(void)+import qualified Data.List.PointedList as PL+import Data.Maybe+import qualified Prelude+import Prelude(length, zipWith)+import Yi.Prelude+import Yi.Layout(Orientation(..), RelativeSize, DividerPosition, Layout(..), DividerRef)+import System.Glib.Types+import Graphics.UI.Gtk as Gtk hiding(Orientation, Layout)+import Data.IORef++class WidgetLike w where+ -- | Extracts the main widget. This is the widget to be added to the GUI.+ baseWidget :: w -> Widget++----------------------- The WeightedStack type+{- |+A @WeightedStack@ is like a 'VBox' or 'HBox', except that we may specify the ratios of the areas of the child widgets (so this implements the 'Stack' constructor of 'Yi.Layout.Layout'.++Essentially, we implement this layout manager from scratch, by+implementing the 'sizeRequest' and 'sizeAllocate' signals by hand (see+the 'Container' documentation for details, and+http://www.ibm.com/developerworks/linux/library/l-widget-pygtk/ for an+example in Python). Ideally, we would directly subclass the abstract+class 'Container', but Gtk2hs doesn't directly support this. Instead,+we start off with the concrete class 'Fixed', and just override its+layout behaviour.+-}++newtype WeightedStack = WS Fixed+ deriving(GObjectClass, ObjectClass, WidgetClass,ContainerClass)++type StackDescr = [(Widget, RelativeSize)]++weightedStackNew :: Orientation -> StackDescr -> IO WeightedStack+weightedStackNew o s =+ do+ when (not . null . Prelude.filter ((<= 0) . snd) $ s) $ error "Yi.UI.Pango.WeightedStack.WeightedStack: all weights must be positive"+ l <- fixedNew+ set l (fmap ((containerChild :=) . fst) s)+ void $ Gtk.on l sizeRequest (doSizeRequest o s)+ void $ Gtk.on l sizeAllocate (relayout o s)+ return (WS l)++-- | Requests the smallest size so that each widget gets its requested size+doSizeRequest :: Orientation -> StackDescr -> IO Requisition+doSizeRequest o s =+ let+ (requestAlong, requestAcross) =+ case o of+ Horizontal ->+ (\(Requisition w _) -> fromIntegral w,+ \(Requisition _ h) -> h)+ Vertical ->+ (\(Requisition _ h) -> fromIntegral h,+ \(Requisition w _) -> w)++ totalWeight = sum . fmap snd $ s+ sizeAlong widgetRequests = totalWeight * (maximum . fmap (\(request,relSize) -> (requestAlong request) / relSize) $ widgetRequests)+ sizeAcross widgetRequests = maximum . fmap (requestAcross . fst) $ widgetRequests+ mkRequisition wr =+ case o of+ Horizontal -> Requisition (round $ sizeAlong wr) (sizeAcross wr)+ Vertical -> Requisition (sizeAcross wr) (round $ sizeAlong wr)+ in+ boundRequisition =<< mkRequisition <$> mapM (\(w,relSize) -> (,relSize) <$> widgetSizeRequest w) s+++-- | Bounds the given requisition to not exceed screen dimensions+boundRequisition :: Requisition -> IO Requisition+boundRequisition r@(Requisition w h) =+ do+ mscr <- screenGetDefault+ case mscr of+ Just scr -> Requisition <$> (min w <$> screenGetWidth scr) <*> (min h <$> screenGetHeight scr)+ Nothing -> return r++-- | Position the children appropriately for the given width and height+relayout :: Orientation -> StackDescr -> Rectangle -> IO ()+relayout o s (Rectangle x y width height) =+ let+ totalWeight = sum . fmap snd $ s+ totalSpace = fromIntegral $+ case o of+ Horizontal -> width+ Vertical -> height+ wtMult = totalSpace / totalWeight+ calcPosition pos (widget, wt) = (pos + wt * wtMult, (pos, wt * wtMult, widget))+ widgetToRectangle (round -> pos, round -> size, widget) =+ case o of+ Horizontal -> (Rectangle pos y size height, widget)+ Vertical -> (Rectangle x pos width size, widget)+ startPosition = fromIntegral $+ case o of+ Horizontal -> x+ Vertical -> y+ widgetPositions = fmap widgetToRectangle (snd (mapAccumL calcPosition startPosition s))+ in do+ forM_ widgetPositions $ \(rect, widget) -> widgetSizeAllocate widget rect++------------------------------------------------------- SlidingPair++{-+'SlidingPair' implements the 'Pair' constructor.++Most of what is needed is already implemented by the 'HPaned' and+'VPaned' classes. The main feature added by 'SlidingPair' is that the+divider position, *as a fraction of the available space*, remains+constant even when resizing.+-}++newtype SlidingPair = SP Paned+ deriving(GObjectClass, ObjectClass, WidgetClass, ContainerClass)++slidingPairNew :: (WidgetClass w1, WidgetClass w2) => Orientation -> w1 -> w2 -> DividerPosition -> (DividerPosition -> IO ()) -> IO SlidingPair+slidingPairNew o w1 w2 pos handleNewPos = do+ p <-+ case o of+ Horizontal -> toPaned <$> hPanedNew+ Vertical -> toPaned <$> vPanedNew+ panedPack1 p w1 True True+ panedPack2 p w2 True True++{- We want to catch the sizeAllocate signal. If this event is+called, two things could have happened: the size could have changed;+or the slider could have moved. We want to correct the slider+position, but only if the size has changed. Furthermore, if the size+only changes in the direction /orthogonal/ to the slider, then there+is also no need to correct the slider position.++-}++ posRef <- newIORef pos+ sizeRef <- newIORef 0++ void $ Gtk.on p sizeAllocate $ \(Rectangle _ _ w h) ->+ do+ oldSz <- readIORef sizeRef+ oldPos <- readIORef posRef++ let sz = case o of+ Horizontal -> w+ Vertical -> h+ writeIORef sizeRef sz+ when (sz /= 0) $+ if sz == oldSz+ then do -- the slider was moved; store its new position+ sliderPos <- get p panedPosition+ let newPos = fromIntegral sliderPos / fromIntegral sz+ writeIORef posRef newPos+ when (oldPos /= newPos) $ handleNewPos newPos+ else do -- the size was changed; restore the slider position and save the new position+ set p [ panedPosition := round (oldPos * fromIntegral sz) ]++ return (SP p)++----------------------------- LayoutDisplay+-- | A container implements 'Layout's.+data LayoutDisplay+ = LD {+ mainWidget :: Bin,+ implWidget :: IORef (Maybe LayoutImpl),+ dividerCallbacks :: IORef [DividerRef -> DividerPosition -> IO ()]+ }++-- | Tree mirroring 'Layout', which holds the layout widgets for 'LayoutDisplay'+data LayoutImpl+ = SingleWindowI {+ singleWidget :: Widget+ }+ | StackI {+ orientationI :: Orientation,+ winsI :: [(LayoutImpl, RelativeSize)],+ stackWidget :: WeightedStack+ }+ | PairI {+ orientationI :: Orientation,+ pairFstI :: LayoutImpl,+ pairSndI :: LayoutImpl,+ divRefI :: DividerRef,+ pairWidget :: SlidingPair+ }++--- construction+layoutDisplayNew :: IO LayoutDisplay+layoutDisplayNew = do+ cbRef <- newIORef []+ implRef <- newIORef Nothing+ box <- toBin <$> alignmentNew 0 0 1 1+ return (LD box implRef cbRef)++-- | Registers a callback to a divider changing position. (There is currently no way to unregister.)+layoutDisplayOnDividerMove :: LayoutDisplay -> (DividerRef -> DividerPosition -> IO ()) -> IO ()+layoutDisplayOnDividerMove ld cb = modifyIORef (dividerCallbacks ld) (cb:)++--- changing the layout+{- | Sets the layout to the given schema.++ * it is permissible to add or remove widgets in this process.++ * as an optimisation, this function will first check whether the layout has actually changed (so the caller need not be concerned with this)++ * will run 'widgetShowAll', and hence will show the underlying widgets too+-}+layoutDisplaySet :: LayoutDisplay -> Layout Widget -> IO ()+layoutDisplaySet ld lyt = do+ mimpl <- readIORef (implWidget ld)++ let applyLayout = do+ impl' <- buildImpl (runCb $ dividerCallbacks ld) lyt+ widgetShowAll (outerWidget impl')+ set (mainWidget ld) [containerChild := outerWidget impl']+ writeIORef (implWidget ld) (Just impl')++ case mimpl of+ Nothing -> applyLayout+ Just impl -> if sameLayout impl lyt then return () else do+ unattachWidgets (toContainer $ mainWidget ld) impl+ applyLayout++runCb :: IORef [DividerRef -> DividerPosition -> IO ()] -> DividerRef -> DividerPosition -> IO ()+runCb cbRef dRef dPos = readIORef cbRef >>= mapM_ (\cb -> cb dRef dPos)++buildImpl :: (DividerRef -> DividerPosition -> IO ()) -> Layout Widget -> IO LayoutImpl+buildImpl cb = go+ where+ go (SingleWindow w) = return (SingleWindowI w)+ go (s@Stack{}) = do+ impls <- forM (wins s) $ \(lyt,relSize) -> (,relSize) <$> go lyt+ ws <- weightedStackNew (orientation s) (fmap (mapFst outerWidget) impls)+ return (StackI (orientation s) impls ws)+ go (p@Pair{}) = do+ w1 <- go (pairFst p)+ w2 <- go (pairSnd p)+ sp <- slidingPairNew (orientation p) (outerWidget w1) (outerWidget w2) (divPos p) (cb (divRef p))+ return $ PairI (orientation p) w1 w2 (divRef p) sp++-- true if the displayed layout agrees with the given schema, other than divider positions+sameLayout :: LayoutImpl -> Layout Widget -> Bool+sameLayout (SingleWindowI w) (SingleWindow w') = w == w'+sameLayout (s@StackI{}) (s'@Stack{}) =+ orientationI s == orientation s'+ && length (winsI s) == length (wins s')+ && and (zipWith (\(impl, relSize) (layout, relSize') -> relSize == relSize' && sameLayout impl layout) (winsI s) (wins s'))+sameLayout (p@PairI{}) (p'@Pair{}) =+ orientationI p == orientation p'+ && divRefI p == divRef p'+ && sameLayout (pairFstI p) (pairFst p')+ && sameLayout (pairSndI p) (pairSnd p')+sameLayout _ _ = False++-- removes all widgets from the layout+unattachWidgets :: Container -> LayoutImpl -> IO ()+unattachWidgets parent (SingleWindowI w) = containerRemove parent w+unattachWidgets parent s@StackI{} = do+ containerRemove parent (stackWidget s)+ mapM_ (unattachWidgets (toContainer $ stackWidget s) . fst) (winsI s)+unattachWidgets parent p@PairI{} = do+ containerRemove parent (pairWidget p)+ mapM_ (unattachWidgets (toContainer $ pairWidget p)) [pairFstI p, pairSndI p]+++-- extract the main widget from the tree+outerWidget :: LayoutImpl -> Widget+outerWidget s@SingleWindowI{} = singleWidget s+outerWidget s@StackI{} = toWidget . stackWidget $ s+outerWidget p@PairI{} = toWidget . pairWidget $ p++instance WidgetLike LayoutDisplay where+ baseWidget = toWidget . mainWidget++-- TODO: use from Data.Tuple.HT+mapFst :: (a -> c) -> (a, b) -> (c, b)+mapFst f (a,b) = (f a, b)++---------------- MiniwindowDisplay+data MiniwindowDisplay+ = MD+ { mwdMainWidget :: VBox,+ mwdWidgets :: IORef [Widget]+ }++miniwindowDisplayNew :: IO MiniwindowDisplay+miniwindowDisplayNew = do+ vb <- vBoxNew False 1+ wsRef <- newIORef []+ return (MD vb wsRef)++instance WidgetLike MiniwindowDisplay where+ baseWidget = toWidget . mwdMainWidget++miniwindowDisplaySet :: MiniwindowDisplay -> [Widget] -> IO ()+miniwindowDisplaySet mwd ws = do+ curWs <- readIORef (mwdWidgets mwd)++ -- we could be more careful here, and only remove the widgets which we need to.+ when (ws /= curWs) $ do+ forM_ curWs $ containerRemove (mwdMainWidget mwd)+ forM_ ws $ \w -> boxPackEnd (mwdMainWidget mwd) w PackNatural 0+ widgetShowAll $ mwdMainWidget mwd+ writeIORef (mwdWidgets mwd) ws+++---------------------- SimpleNotebook+data SimpleNotebook+ = SN+ { snMainWidget :: Notebook,+ snTabs :: IORef (Maybe (PL.PointedList (Widget, String)))+ }++instance WidgetLike SimpleNotebook where+ baseWidget = toWidget . snMainWidget++-- | Constructs an empty notebook+simpleNotebookNew :: IO SimpleNotebook+simpleNotebookNew = do+ nb <- notebookNew+ ts <- newIORef Nothing+ return (SN nb ts)++-- | Sets the tabs+simpleNotebookSet :: SimpleNotebook -> PL.PointedList (Widget, String) -> IO ()+simpleNotebookSet sn ts = do+ curTs <- readIORef (snTabs sn)++ let nb = snMainWidget sn+ tsList = toList ts+ curTsList = maybe [] toList curTs++ -- the common case is no change at all+ when (curTs /= Just ts) $ do++ -- update the tabs, if they have changed+ when (fmap fst curTsList /= fmap fst tsList) $ do+ forM_ curTsList $ const (notebookRemovePage nb (-1))+ forM_ tsList $ \(w,s) -> notebookAppendPage nb w s++ -- now update the titles if they have changed+ forM_ tsList $ \(w,s) -> update nb (notebookChildTabLabel w) s++ -- now set the focus+ p <- notebookPageNum nb (fst $ PL.focus ts)+ maybe (return ()) (update nb notebookPage) p++ -- write the new status+ writeIORef (snTabs sn) (Just ts)++ -- display!+ widgetShowAll nb+++-- | The 'onSwitchPage' callback+simpleNotebookOnSwitchPage :: SimpleNotebook -> (Int -> IO ()) -> IO ()+simpleNotebookOnSwitchPage sn cb = void $ onSwitchPage (snMainWidget sn) cb+++------------------- Utils+-- Only set an attribute if has actually changed.+-- This makes setting window titles much faster.+update :: (Eq a) => o -> ReadWriteAttr o a a -> a -> IO ()+update w attr val = do oldVal <- get w attr+ when (val /= oldVal) $ set w [attr := val]
src/library/Yi/UI/TabBar.hs view
@@ -5,6 +5,7 @@ import System.FilePath import Yi.Buffer (shortIdentString)+import Yi.Tab import Yi.Window import Yi.Editor (Editor(..) ,commonNamePrefix@@ -21,7 +22,7 @@ tabBarDescr :: Editor -> TabBarDescr tabBarDescr editor = let prefix = commonNamePrefix editor- hintForTab tab = tabAbbrevTitle $ shortIdentString prefix $ findBufferWith (bufkey $ PL.focus tab) editor+ hintForTab tab = tabAbbrevTitle $ shortIdentString prefix $ findBufferWith (bufkey $ PL.focus (tab ^. tabWindowsA)) editor tabDescr (tab,True) = TabDescr (hintForTab tab) True tabDescr (tab,False) = TabDescr (hintForTab tab) False in fmap tabDescr (PL.withFocus $ editor ^. tabsA)
src/library/Yi/UI/Vte.hs view
@@ -5,6 +5,7 @@ import Graphics.UI.Gtk import Graphics.UI.Gtk.Vte.Vte+import System.Environment import System.Environment.Executable import System.Glib @@ -17,7 +18,7 @@ catchGError (initUI cfg ch outCh editor) (\(GError _dom _code msg) -> fail msg) initUI :: UIBoot-initUI cfg ch outCh editor = do+initUI cfg _ch _outCh _editor = do discard unsafeInitGUIForThreadedRTS setApplicationName "Yi" @@ -28,7 +29,7 @@ -- Setup vte exe <- getExecutablePath term <- terminalNew- Graphics.UI.Gtk.on term childExited $ end False+ discard $ Graphics.UI.Gtk.on term childExited $ end False -- Set default colors terminalSetColors term@@ -38,8 +39,9 @@ 0 -- Start running Yi+ args <- getArgs discard $ terminalForkCommand term- (Just exe) (Just [exe, "-fvty"]) Nothing Nothing False False False+ (Just exe) (Just $ exe : args ++ ["-fvty"]) Nothing Nothing False False False discard $ set win [ containerChild := term ] widgetShowAll win@@ -55,6 +57,8 @@ end :: Bool -> IO () end = const mainQuit +getBaseAttrColor :: (Attributes -> Yi.Style.Color) -> Yi.Style.Color+ -> Config -> Graphics.UI.Gtk.Color getBaseAttrColor p d cfg = mkCol $ case p $ baseAttributes $ configStyle $ configUI cfg of Default -> d
src/library/Yi/UI/Vty.hs view
@@ -156,6 +156,7 @@ fromVtyKey (Vty.KRight ) = Yi.Event.KRight fromVtyKey (Vty.KEnter ) = Yi.Event.KEnter fromVtyKey (Vty.KBackTab ) = error "This should be handled in fromVtyEvent"+fromVtyKey (Vty.KBegin ) = error "Yi.UI.Vty.fromVtyKey: can't handle KBegin" fromVtyMod :: Vty.Modifier -> Yi.Event.Modifier fromVtyMod Vty.MShift = Yi.Event.MShift
src/library/Yi/Window.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, GeneralizedNewtypeDeriving #-} -- -- Copyright (c) 2008 JP Bernardy@@ -6,17 +6,16 @@ -- module Yi.Window where++import qualified Prelude+import Yi.Prelude import Data.Binary-import Data.Typeable-import Yi.Buffer.Basic (BufferRef)+import Yi.Buffer.Basic (BufferRef, WindowRef) import Yi.Region (Region,emptyRegion)-import Control.Applicative ------------------------------------------------------------------------ -- | A window onto a buffer. -type WindowRef = Int- data Window = Window { isMini :: !Bool -- ^ regular or mini window? ,bufkey :: !BufferRef -- ^ the buffer this window opens to@@ -59,10 +58,7 @@ pointInWindow point win = tospnt win <= point && point <= bospnt win -} -dummyWindowKey :: Int-dummyWindowKey = (-1)- -- | Return a "fake" window onto a buffer. dummyWindow :: BufferRef -> Window-dummyWindow b = Window False b [] 0 emptyRegion dummyWindowKey 0+dummyWindow b = Window False b [] 0 emptyRegion initial 0
src/tests/Driver.hs view
@@ -2,15 +2,12 @@ module Driver where -import Data.Maybe import System.Environment import Control.Monad import Test.QuickCheck hiding (promote)-import System.IO import System.Random hiding (next) import Text.Printf import Data.List (sort,group,intersperse)-import qualified Data.List as L -- Following code shamelessly stolen from XMonad. main :: (Read t, Num t, PrintfArg t1, Num b, PrintfArg b) =>@@ -19,7 +16,7 @@ args <- fmap (drop 1) getArgs let n = if null args then 100 else read (head args) (results, passed) <- fmap unzip $ mapM (\(s,a) -> printf "%-25s: " s >> a n) tests- printf "Passed %d tests!\n" (sum passed)+ printf "Passed %d tests!\n" (sum passed) :: IO () when (not . and $ results) $ fail "Not all tests passed!" ------------------------------------------------------------------------
yi.cabal view
@@ -1,5 +1,5 @@ name: yi-version: 0.6.3.0+version: 0.6.4.0 category: Development, Editor synopsis: The Haskell-Scriptable Editor description:@@ -17,6 +17,7 @@ data-files: art/*.png+ art/*.pdf example-configs/*.hs extra-source-files: src/library/Yi/Lexer/common.hsinc@@ -62,6 +63,13 @@ flag testing Description: bake-in the self-checks +flag dochack+ Default: False+ Description:+ Hack to get Haddock documentation, by disabling executables.+ * this is a workaround for a cabal bug; see Issue #347+ * do a 'cabal install yi -fdochack' followed by 'cabal install yi' to get yi and the documentation+ library hs-source-dirs: src/library default-language: Haskell2010@@ -85,6 +93,8 @@ Yi.Config Yi.Config.Default Yi.Config.Misc+ Yi.Config.Simple+ Yi.Config.Simple.Types Yi.Core Yi.Debug Yi.Dired@@ -95,6 +105,7 @@ Yi.File Yi.History Yi.Hoogle+ Yi.Hooks Yi.IReader Yi.IncrementalParse Yi.Interact@@ -107,6 +118,7 @@ Yi.Keymap.Keys Yi.Keymap.Vim Yi.KillRing+ Yi.Layout Yi.Lexer.Abella Yi.Lexer.Alex Yi.Lexer.Cabal@@ -116,8 +128,10 @@ Yi.Lexer.Cplusplus Yi.Lexer.Haskell Yi.Lexer.JavaScript+ Yi.Lexer.Java Yi.Lexer.Latex Yi.Lexer.LiterateHaskell+ Yi.Lexer.GitCommit Yi.Lexer.GNUMake Yi.Lexer.OCaml Yi.Lexer.Ott@@ -161,6 +175,7 @@ Yi.Syntax.Paren Yi.Syntax.Tree Yi.Syntax.Strokes.Haskell+ Yi.Tab Yi.Tag Yi.TextCompletion, Yi.UI.Common@@ -184,6 +199,8 @@ base >=4 && <5, binary == 0.5.*, bytestring >=0.9.1 && <0.9.2,+ cautious-file == 1.0.*,+ concrete-typerep == 0.1.*, derive >=2.4 && <2.5, data-accessor >= 0.2.1.4 && < 0.3, data-accessor-monads-fd == 0.2.*,@@ -193,6 +210,7 @@ filepath>=1.1 && <1.3, fingertree >= 0 && <0.1, ghc-paths ==0.1.*,+ hashable < 1.2, hint > 0.3.1, monads-fd >= 0.1.0.1, pointedlist >= 0.3.5 && <0.4,@@ -206,17 +224,17 @@ time >= 1.1 && < 1.3, utf8-string >= 0.3.1, uniplate,- unix-compat >=0.1 && <0.3+ unix-compat >=0.1 && <0.3,+ unordered-containers >= 0.1.3 && < 0.2 + build-tools: alex ghc-options: -Wall -fno-warn-orphans if flag(hacking) ghc-prof-options: -prof -auto-all if !os(windows) build-depends:- cautious-file >= 0.1.5 && <0.2, unix- cpp-options: -DCAUTIOUS_WRITES include-dirs: src/library/Yi/Lexer @@ -248,6 +266,7 @@ Yi.UI.Pango Yi.UI.Pango.Control other-modules:+ Yi.UI.Pango.Layouts Yi.UI.Pango.Utils build-depends: gtk ==0.12.*,@@ -277,6 +296,9 @@ if flag (scion) cpp-options: -DSCION exposed-modules: Yi.Scion+ build-depends: scion == 0.1.*,+ ghc >= 7,+ ghc-syb-utils if flag (ghcAPI) cpp-options: -DGHC_API@@ -298,6 +320,7 @@ Shim.CabalInfo Shim.Utils Shim.ProjectContent+ System.CanonicalizePath System.FriendlyPath -- Broken.@@ -315,7 +338,7 @@ hs-source-dirs: src/parsertest default-language: Haskell2010 - if !flag(hacking)+ if !flag(hacking) || flag(dochack) buildable: False main-is: ParserTest/ParserTest.hs@@ -325,17 +348,22 @@ array, containers, directory,- filepath>=1.1 && <1.3,- yi+ filepath>=1.1 && <1.3+ if !flag(dochack)+ build-depends: yi executable yi hs-source-dirs: src/executable default-language: Haskell2010 + if flag(dochack)+ buildable: False+ main-is: Main.hs build-depends:- base >=4 && <5,- yi-+ base >=4 && <5+ if !flag(dochack)+ build-depends: yi+ build-tools: alex ghc-options: -threaded