diff --git a/art/yi+lambda-fat-128.png b/art/yi+lambda-fat-128.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-128.png differ diff --git a/art/yi+lambda-fat-16.png b/art/yi+lambda-fat-16.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-16.png differ diff --git a/art/yi+lambda-fat-32.png b/art/yi+lambda-fat-32.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-32.png differ diff --git a/art/yi+lambda-fat-64.png b/art/yi+lambda-fat-64.png new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat-64.png differ diff --git a/art/yi+lambda-fat.pdf b/art/yi+lambda-fat.pdf new file mode 100644 Binary files /dev/null and b/art/yi+lambda-fat.pdf differ diff --git a/src/library/Data/Rope.hs b/src/library/Data/Rope.hs --- a/src/library/Data/Rope.hs +++ b/src/library/Data/Rope.hs @@ -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 diff --git a/src/library/Data/Trie.hs b/src/library/Data/Trie.hs --- a/src/library/Data/Trie.hs +++ b/src/library/Data/Trie.hs @@ -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) diff --git a/src/library/Parser/Incremental.hs b/src/library/Parser/Incremental.hs --- a/src/library/Parser/Incremental.hs +++ b/src/library/Parser/Incremental.hs @@ -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) diff --git a/src/library/Shim/CabalInfo.hs b/src/library/Shim/CabalInfo.hs --- a/src/library/Shim/CabalInfo.hs +++ b/src/library/Shim/CabalInfo.hs @@ -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 diff --git a/src/library/Shim/Hsinfo.hs b/src/library/Shim/Hsinfo.hs --- a/src/library/Shim/Hsinfo.hs +++ b/src/library/Shim/Hsinfo.hs @@ -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 diff --git a/src/library/Shim/ProjectContent.hs b/src/library/Shim/ProjectContent.hs --- a/src/library/Shim/ProjectContent.hs +++ b/src/library/Shim/ProjectContent.hs @@ -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 +-} diff --git a/src/library/Shim/Utils.hs b/src/library/Shim/Utils.hs --- a/src/library/Shim/Utils.hs +++ b/src/library/Shim/Utils.hs @@ -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) diff --git a/src/library/System/CanonicalizePath.hs b/src/library/System/CanonicalizePath.hs new file mode 100644 --- /dev/null +++ b/src/library/System/CanonicalizePath.hs @@ -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] diff --git a/src/library/System/FriendlyPath.hs b/src/library/System/FriendlyPath.hs --- a/src/library/System/FriendlyPath.hs +++ b/src/library/System/FriendlyPath.hs @@ -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 diff --git a/src/library/Yi/Boot.hs b/src/library/Yi/Boot.hs --- a/src/library/Yi/Boot.hs +++ b/src/library/Yi/Boot.hs @@ -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 diff --git a/src/library/Yi/Buffer/Basic.hs b/src/library/Yi/Buffer/Basic.hs --- a/src/library/Yi/Buffer/Basic.hs +++ b/src/library/Yi/Buffer/Basic.hs @@ -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) + diff --git a/src/library/Yi/Buffer/HighLevel.hs b/src/library/Yi/Buffer/HighLevel.hs --- a/src/library/Yi/Buffer/HighLevel.hs +++ b/src/library/Yi/Buffer/HighLevel.hs @@ -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 diff --git a/src/library/Yi/Buffer/Implementation.hs b/src/library/Yi/Buffer/Implementation.hs --- a/src/library/Yi/Buffer/Implementation.hs +++ b/src/library/Yi/Buffer/Implementation.hs @@ -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)} diff --git a/src/library/Yi/Buffer/Misc.hs b/src/library/Yi/Buffer/Misc.hs --- a/src/library/Yi/Buffer/Misc.hs +++ b/src/library/Yi/Buffer/Misc.hs @@ -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"))) diff --git a/src/library/Yi/Buffer/Normal.hs b/src/library/Yi/Buffer/Normal.hs --- a/src/library/Yi/Buffer/Normal.hs +++ b/src/library/Yi/Buffer/Normal.hs @@ -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 diff --git a/src/library/Yi/Buffer/Region.hs b/src/library/Yi/Buffer/Region.hs --- a/src/library/Yi/Buffer/Region.hs +++ b/src/library/Yi/Buffer/Region.hs @@ -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. diff --git a/src/library/Yi/Buffer/Undo.hs b/src/library/Yi/Buffer/Undo.hs --- a/src/library/Yi/Buffer/Undo.hs +++ b/src/library/Yi/Buffer/Undo.hs @@ -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 diff --git a/src/library/Yi/Command.hs b/src/library/Yi/Command.hs --- a/src/library/Yi/Command.hs +++ b/src/library/Yi/Command.hs @@ -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 diff --git a/src/library/Yi/Config.hs b/src/library/Yi/Config.hs --- a/src/library/Yi/Config.hs +++ b/src/library/Yi/Config.hs @@ -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"))) diff --git a/src/library/Yi/Config/Default.hs b/src/library/Yi/Config/Default.hs --- a/src/library/Yi/Config/Default.hs +++ b/src/library/Yi/Config/Default.hs @@ -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 diff --git a/src/library/Yi/Config/Simple.hs b/src/library/Yi/Config/Simple.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/Config/Simple.hs @@ -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 + diff --git a/src/library/Yi/Config/Simple/Types.hs b/src/library/Yi/Config/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/Config/Simple/Types.hs @@ -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 diff --git a/src/library/Yi/Core.hs b/src/library/Yi/Core.hs --- a/src/library/Yi/Core.hs +++ b/src/library/Yi/Core.hs @@ -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 diff --git a/src/library/Yi/Debug.hs b/src/library/Yi/Debug.hs --- a/src/library/Yi/Debug.hs +++ b/src/library/Yi/Debug.hs @@ -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 () diff --git a/src/library/Yi/Dired.hs b/src/library/Yi/Dired.hs --- a/src/library/Yi/Dired.hs +++ b/src/library/Yi/Dired.hs @@ -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 diff --git a/src/library/Yi/Dynamic.hs b/src/library/Yi/Dynamic.hs --- a/src/library/Yi/Dynamic.hs +++ b/src/library/Yi/Dynamic.hs @@ -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?). +-} diff --git a/src/library/Yi/Editor.hs b/src/library/Yi/Editor.hs --- a/src/library/Yi/Editor.hs +++ b/src/library/Yi/Editor.hs @@ -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 + diff --git a/src/library/Yi/Eval.hs b/src/library/Yi/Eval.hs --- a/src/library/Yi/Eval.hs +++ b/src/library/Yi/Eval.hs @@ -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 diff --git a/src/library/Yi/Event.hs b/src/library/Yi/Event.hs --- a/src/library/Yi/Event.hs +++ b/src/library/Yi/Event.hs @@ -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 diff --git a/src/library/Yi/File.hs b/src/library/Yi/File.hs --- a/src/library/Yi/File.hs +++ b/src/library/Yi/File.hs @@ -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@ diff --git a/src/library/Yi/History.hs b/src/library/Yi/History.hs --- a/src/library/Yi/History.hs +++ b/src/library/Yi/History.hs @@ -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 diff --git a/src/library/Yi/Hoogle.hs b/src/library/Yi/Hoogle.hs --- a/src/library/Yi/Hoogle.hs +++ b/src/library/Yi/Hoogle.hs @@ -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] diff --git a/src/library/Yi/Hooks.hs b/src/library/Yi/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/Hooks.hs @@ -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) diff --git a/src/library/Yi/IReader.hs b/src/library/Yi/IReader.hs --- a/src/library/Yi/IReader.hs +++ b/src/library/Yi/IReader.hs @@ -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 diff --git a/src/library/Yi/IncrementalParse.hs b/src/library/Yi/IncrementalParse.hs --- a/src/library/Yi/IncrementalParse.hs +++ b/src/library/Yi/IncrementalParse.hs @@ -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) diff --git a/src/library/Yi/Keymap.hs b/src/library/Yi/Keymap.hs --- a/src/library/Yi/Keymap.hs +++ b/src/library/Yi/Keymap.hs @@ -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)) -------------------------------- diff --git a/src/library/Yi/Keymap/Emacs.hs b/src/library/Yi/Keymap/Emacs.hs --- a/src/library/Yi/Keymap/Emacs.hs +++ b/src/library/Yi/Keymap/Emacs.hs @@ -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 diff --git a/src/library/Yi/Keymap/Emacs/KillRing.hs b/src/library/Yi/Keymap/Emacs/KillRing.hs --- a/src/library/Yi/Keymap/Emacs/KillRing.hs +++ b/src/library/Yi/Keymap/Emacs/KillRing.hs @@ -6,7 +6,6 @@ import Prelude () import Yi.Prelude -import Yi.Monad import Yi.Keymap import Yi.Buffer import Yi.Editor diff --git a/src/library/Yi/Keymap/Emacs/Utils.hs b/src/library/Yi/Keymap/Emacs/Utils.hs --- a/src/library/Yi/Keymap/Emacs/Utils.hs +++ b/src/library/Yi/Keymap/Emacs/Utils.hs @@ -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 +-} diff --git a/src/library/Yi/Keymap/Keys.hs b/src/library/Yi/Keymap/Keys.hs --- a/src/library/Yi/Keymap/Keys.hs +++ b/src/library/Yi/Keymap/Keys.hs @@ -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 diff --git a/src/library/Yi/Keymap/Vim.hs b/src/library/Yi/Keymap/Vim.hs --- a/src/library/Yi/Keymap/Vim.hs +++ b/src/library/Yi/Keymap/Vim.hs @@ -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 diff --git a/src/library/Yi/KillRing.hs b/src/library/Yi/KillRing.hs --- a/src/library/Yi/KillRing.hs +++ b/src/library/Yi/KillRing.hs @@ -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 diff --git a/src/library/Yi/Layout.hs b/src/library/Yi/Layout.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/Layout.hs @@ -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 diff --git a/src/library/Yi/Lexer/Alex.hs b/src/library/Yi/Lexer/Alex.hs --- a/src/library/Yi/Lexer/Alex.hs +++ b/src/library/Yi/Lexer/Alex.hs @@ -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) diff --git a/src/library/Yi/Lexer/GitCommit.x b/src/library/Yi/Lexer/GitCommit.x new file mode 100644 --- /dev/null +++ b/src/library/Yi/Lexer/GitCommit.x @@ -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. + { +.+ { 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. + { +^@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 context to highlight +-- everything to the end of the line (which should only ever be a filename.) + { +$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 } +} + + { +$nl { m (const MessageLine) Style.defaultStyle } +. { c Style.preprocessorStyle } +} + +-- Highlight diff lines + { +^@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" +} + diff --git a/src/library/Yi/Lexer/Java.x b/src/library/Yi/Lexer/Java.x new file mode 100644 --- /dev/null +++ b/src/library/Yi/Lexer/Java.x @@ -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 + + { + "*/" { 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" +} diff --git a/src/library/Yi/Main.hs b/src/library/Yi/Main.hs --- a/src/library/Yi/Main.hs +++ b/src/library/Yi/Main.hs @@ -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 diff --git a/src/library/Yi/MiniBuffer.hs b/src/library/Yi/MiniBuffer.hs --- a/src/library/Yi/MiniBuffer.hs +++ b/src/library/Yi/MiniBuffer.hs @@ -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 diff --git a/src/library/Yi/Misc.hs b/src/library/Yi/Misc.hs --- a/src/library/Yi/Misc.hs +++ b/src/library/Yi/Misc.hs @@ -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 diff --git a/src/library/Yi/Mode/Abella.hs b/src/library/Yi/Mode/Abella.hs --- a/src/library/Yi/Mode/Abella.hs +++ b/src/library/Yi/Mode/Abella.hs @@ -46,6 +46,7 @@ newtype AbellaBuffer = AbellaBuffer {_abellaBuffer :: Maybe BufferRef} deriving (Initializable, Typeable, Binary) +instance YiVariable AbellaBuffer getProofPointMark :: BufferM Mark getProofPointMark = getMarkB $ Just "p" diff --git a/src/library/Yi/Mode/Buffers.hs b/src/library/Yi/Mode/Buffers.hs --- a/src/library/Yi/Mode/Buffers.hs +++ b/src/library/Yi/Mode/Buffers.hs @@ -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 ) diff --git a/src/library/Yi/Mode/Compilation.hs b/src/library/Yi/Mode/Compilation.hs --- a/src/library/Yi/Mode/Compilation.hs +++ b/src/library/Yi/Mode/Compilation.hs @@ -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 () diff --git a/src/library/Yi/Mode/Haskell.hs b/src/library/Yi/Mode/Haskell.hs --- a/src/library/Yi/Mode/Haskell.hs +++ b/src/library/Yi/Mode/Haskell.hs @@ -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 diff --git a/src/library/Yi/Mode/Haskell/Dollarify.hs b/src/library/Yi/Mode/Haskell/Dollarify.hs --- a/src/library/Yi/Mode/Haskell/Dollarify.hs +++ b/src/library/Yi/Mode/Haskell/Dollarify.hs @@ -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 diff --git a/src/library/Yi/Mode/JavaScript.hs b/src/library/Yi/Mode/JavaScript.hs --- a/src/library/Yi/Mode/JavaScript.hs +++ b/src/library/Yi/Mode/JavaScript.hs @@ -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 () diff --git a/src/library/Yi/Modes.hs b/src/library/Yi/Modes.hs --- a/src/library/Yi/Modes.hs +++ b/src/library/Yi/Modes.hs @@ -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 diff --git a/src/library/Yi/Monad.hs b/src/library/Yi/Monad.hs --- a/src/library/Yi/Monad.hs +++ b/src/library/Yi/Monad.hs @@ -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' diff --git a/src/library/Yi/Prelude.hs b/src/library/Yi/Prelude.hs --- a/src/library/Yi/Prelude.hs +++ b/src/library/Yi/Prelude.hs @@ -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 diff --git a/src/library/Yi/Process.hs b/src/library/Yi/Process.hs --- a/src/library/Yi/Process.hs +++ b/src/library/Yi/Process.hs @@ -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" diff --git a/src/library/Yi/Rectangle.hs b/src/library/Yi/Rectangle.hs --- a/src/library/Yi/Rectangle.hs +++ b/src/library/Yi/Rectangle.hs @@ -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 diff --git a/src/library/Yi/Regex.hs b/src/library/Yi/Regex.hs --- a/src/library/Yi/Regex.hs +++ b/src/library/Yi/Regex.hs @@ -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 ( diff --git a/src/library/Yi/Region.hs b/src/library/Yi/Region.hs --- a/src/library/Yi/Region.hs +++ b/src/library/Yi/Region.hs @@ -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) ++ diff --git a/src/library/Yi/Scion.hs b/src/library/Yi/Scion.hs --- a/src/library/Yi/Scion.hs +++ b/src/library/Yi/Scion.hs @@ -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) diff --git a/src/library/Yi/Search.hs b/src/library/Yi/Search.hs --- a/src/library/Yi/Search.hs +++ b/src/library/Yi/Search.hs @@ -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 diff --git a/src/library/Yi/Snippets.hs b/src/library/Yi/Snippets.hs --- a/src/library/Yi/Snippets.hs +++ b/src/library/Yi/Snippets.hs @@ -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 diff --git a/src/library/Yi/Style.hs b/src/library/Yi/Style.hs --- a/src/library/Yi/Style.hs +++ b/src/library/Yi/Style.hs @@ -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 diff --git a/src/library/Yi/Syntax.hs b/src/library/Yi/Syntax.hs --- a/src/library/Yi/Syntax.hs +++ b/src/library/Yi/Syntax.hs @@ -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.) } diff --git a/src/library/Yi/Syntax/Driver.hs b/src/library/Yi/Syntax/Driver.hs --- a/src/library/Yi/Syntax/Driver.hs +++ b/src/library/Yi/Syntax/Driver.hs @@ -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 diff --git a/src/library/Yi/Syntax/Haskell.hs b/src/library/Yi/Syntax/Haskell.hs --- a/src/library/Yi/Syntax/Haskell.hs +++ b/src/library/Yi/Syntax/Haskell.hs @@ -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 diff --git a/src/library/Yi/Syntax/Latex.hs b/src/library/Yi/Syntax/Latex.hs --- a/src/library/Yi/Syntax/Latex.hs +++ b/src/library/Yi/Syntax/Latex.hs @@ -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 diff --git a/src/library/Yi/Syntax/Layout.hs b/src/library/Yi/Syntax/Layout.hs --- a/src/library/Yi/Syntax/Layout.hs +++ b/src/library/Yi/Syntax/Layout.hs @@ -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 diff --git a/src/library/Yi/Syntax/OnlineTree.hs b/src/library/Yi/Syntax/OnlineTree.hs --- a/src/library/Yi/Syntax/OnlineTree.hs +++ b/src/library/Yi/Syntax/OnlineTree.hs @@ -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) diff --git a/src/library/Yi/Syntax/Paren.hs b/src/library/Yi/Syntax/Paren.hs --- a/src/library/Yi/Syntax/Paren.hs +++ b/src/library/Yi/Syntax/Paren.hs @@ -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 diff --git a/src/library/Yi/Syntax/Strokes/Haskell.hs b/src/library/Yi/Syntax/Strokes/Haskell.hs --- a/src/library/Yi/Syntax/Strokes/Haskell.hs +++ b/src/library/Yi/Syntax/Strokes/Haskell.hs @@ -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) diff --git a/src/library/Yi/Syntax/Tree.hs b/src/library/Yi/Syntax/Tree.hs --- a/src/library/Yi/Syntax/Tree.hs +++ b/src/library/Yi/Syntax/Tree.hs @@ -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 diff --git a/src/library/Yi/Tab.hs b/src/library/Yi/Tab.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/Tab.hs @@ -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) diff --git a/src/library/Yi/Tag.hs b/src/library/Yi/Tag.hs --- a/src/library/Yi/Tag.hs +++ b/src/library/Yi/Tag.hs @@ -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 + diff --git a/src/library/Yi/TextCompletion.hs b/src/library/Yi/TextCompletion.hs --- a/src/library/Yi/TextCompletion.hs +++ b/src/library/Yi/TextCompletion.hs @@ -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 () diff --git a/src/library/Yi/UI/Common.hs b/src/library/Yi/UI/Common.hs --- a/src/library/Yi/UI/Common.hs +++ b/src/library/Yi/UI/Common.hs @@ -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' diff --git a/src/library/Yi/UI/Pango.hs b/src/library/Yi/UI/Pango.hs --- a/src/library/Yi/UI/Pango.hs +++ b/src/library/Yi/UI/Pango.hs @@ -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" +-} diff --git a/src/library/Yi/UI/Pango/Control.hs b/src/library/Yi/UI/Pango/Control.hs --- a/src/library/Yi/UI/Pango/Control.hs +++ b/src/library/Yi/UI/Pango/Control.hs @@ -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) + ] diff --git a/src/library/Yi/UI/Pango/Layouts.hs b/src/library/Yi/UI/Pango/Layouts.hs new file mode 100644 --- /dev/null +++ b/src/library/Yi/UI/Pango/Layouts.hs @@ -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] diff --git a/src/library/Yi/UI/TabBar.hs b/src/library/Yi/UI/TabBar.hs --- a/src/library/Yi/UI/TabBar.hs +++ b/src/library/Yi/UI/TabBar.hs @@ -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) diff --git a/src/library/Yi/UI/Vte.hs b/src/library/Yi/UI/Vte.hs --- a/src/library/Yi/UI/Vte.hs +++ b/src/library/Yi/UI/Vte.hs @@ -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 diff --git a/src/library/Yi/UI/Vty.hs b/src/library/Yi/UI/Vty.hs --- a/src/library/Yi/UI/Vty.hs +++ b/src/library/Yi/UI/Vty.hs @@ -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 diff --git a/src/library/Yi/Window.hs b/src/library/Yi/Window.hs --- a/src/library/Yi/Window.hs +++ b/src/library/Yi/Window.hs @@ -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 diff --git a/src/tests/Driver.hs b/src/tests/Driver.hs --- a/src/tests/Driver.hs +++ b/src/tests/Driver.hs @@ -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!" ------------------------------------------------------------------------ diff --git a/yi.cabal b/yi.cabal --- a/yi.cabal +++ b/yi.cabal @@ -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