diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010, Yoshikuni Jujo +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the Yoshikuni Jujo nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,73 @@ +module Main ( main ) where + +import MainNoPaths ( getYavieDir ) +import qualified MainNoPaths as NP ( main ) + +import System.Environment ( getArgs ) +import System.Directory ( doesDirectoryExist, doesFileExist, + createDirectory, createDirectoryIfMissing, + copyFile ) +import Control.Monad ( when ) + +import Data.Version ( showVersion ) +import Paths_yavie ( getDataFileName, version ) + +uuidFileName :: String +uuidFileName = "uuid_yavie" + +defaultMains :: [ ( String, [ String ] ) ] +defaultMains = [ vtyFileNames, x11FileNames, gtkFileNames ] + +vtyFileNames :: ( String, [ String ] ) +vtyFileNames = ( "vty", [ "yavie-vty.hs", "yavie-vty.cabal" ] ) + +x11FileNames :: ( String, [ String ] ) +x11FileNames = ( "x11", [ "yavie-x11.hs", "yavie-x11.cabal" ] ) + +gtkFileNames :: ( String, [ String ] ) +gtkFileNames = ( "gtk", [ "yavie-gtk.hs", "yavie-gtk.cabal" ] ) + +main :: IO () +main = do + args <- getArgs + yavieDir <- getYavieDir + uuidYavie <- getDataFileName uuidFileName >>= readFile + existYDir <- doesDirectoryExist yavieDir + if existYDir then checkYDir yavieDir uuidYavie + else do createUUIDFile yavieDir uuidYavie + mapM_ ( copyDefault yavieDir ) defaultMains + case args of + [ "--version" ] -> putStrLn $ "yavie " ++ showVersion version + [ "--reset" ] -> mapM_ ( copyDefault yavieDir ) defaultMains + _ -> NP.main + +checkYDir :: FilePath -> String -> IO () +checkYDir yavieDir uuidYavie = do + let uuidFile = yavieDir ++ "/" ++ uuidFileName + errMsg = "checkYDir: bad yavie directory" + errMsg2 yu du = "checkYDir : bad yavie directory " ++ show yu ++ " " + ++ show du + existUFile <- doesFileExist uuidFile + if not existUFile then error errMsg else do + uuid <- readFile uuidFile + when ( uuid /= uuidYavie ) $ error ( errMsg2 uuidYavie uuid ) + +createUUIDFile :: FilePath -> String -> IO () +createUUIDFile yavieDir uuidYavie = do + let uuidFile = yavieDir ++ "/" ++ uuidFileName + defaultFile = yavieDir ++ "/default" + createDirectory yavieDir + writeFile uuidFile uuidYavie + writeFile defaultFile "vty\n" + +copyDefault :: FilePath -> ( String, [ String ] ) -> IO () +copyDefault yavieDir ( dirName, files ) = do + let dir = yavieDir ++ "/" ++ dirName + createDirectoryIfMissing False dir + mapM_ ( copyToHome ( "src/" ++ dirName ) dir ) files + +copyToHome :: FilePath -> FilePath -> FilePath -> IO () +copyToHome fd td fn = do + fromFile <- getDataFileName $ fd ++ "/" ++ fn + let toFile = td ++ "/" ++ fn + copyFile fromFile toFile diff --git a/src/MainNoPaths.hs b/src/MainNoPaths.hs new file mode 100644 --- /dev/null +++ b/src/MainNoPaths.hs @@ -0,0 +1,78 @@ +module MainNoPaths ( main, getYavieDir ) where + +import System.Environment ( getArgs ) +import System.Directory ( getCurrentDirectory, + setCurrentDirectory, getModificationTime, + getHomeDirectory, doesFileExist, + getDirectoryContents ) +import System.Cmd ( rawSystem ) +import System.Exit ( exitWith ) +import Control.Monad ( when ) +import Distribution.Simple ( defaultMainArgs ) +import System.Console.GetOpt ( getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..) ) + +yavieDirName :: String +yavieDirName = ".yavie" + +getYavieDir :: IO String +getYavieDir = fmap (++ '/' : yavieDirName) getHomeDirectory + +getMainName :: FilePath -> IO ( String, [ String ] ) +getMainName yavieDir = do + args <- getArgs + let ( opts, otherArgs, _err ) = getOpt Permute optDescrs args + name <- getMainIsFromOptions yavieDir opts + return ( name, otherArgs ) + +getMainIsFromOptions :: FilePath -> [ CmdLnOption ] -> IO String +getMainIsFromOptions yavieDir opts = + case filter isMainIs opts of + [ ] -> fmap ( head . lines ) $ readFile ( yavieDir ++ "/default" ) + MainIs mn : _ -> return mn + OptVersion : _ -> error "not occur" + +data CmdLnOption = MainIs { _mainName :: String } | OptVersion + deriving Show +isMainIs :: CmdLnOption -> Bool +isMainIs MainIs { } = True +isMainIs _ = False + +optDescrs :: [ OptDescr CmdLnOption ] +optDescrs = [ optDescrMainIs, optDescrVersion ] + +optDescrMainIs, optDescrVersion :: OptDescr CmdLnOption +optDescrMainIs = Option "" [ "mainIs" ] ( ReqArg MainIs "" ) "" +optDescrVersion = Option "" [ "version" ] ( NoArg OptVersion ) "" + +main :: IO () +main = do + yavieDir <- getYavieDir + ( mn, args ) <- getMainName yavieDir + buildByCabal mn $ yavieDir ++ "/" ++ mn + es <- rawSystem ( yavieDir ++ "/" ++ mn ++ "/bin/yavie-" ++ mn ) args + exitWith es + +buildByCabal :: String -> FilePath -> IO () +buildByCabal mn sd = do + update <- anythingNew ( sd ++ "/bin/yavie-" ++ mn ) sd + when update $ do + cd <- getCurrentDirectory + setCurrentDirectory sd + defaultMainArgs [ "configure", "--prefix=" ++ sd ] + defaultMainArgs [ "build" ] + defaultMainArgs [ "install" ] + setCurrentDirectory cd + +anythingNew :: FilePath -> FilePath -> IO Bool +anythingNew fn dn = do + ext <- doesFileExist fn + if not ext then return True else do + fmt <- getModificationTime fn + fps <- getDirectoryContentsPath dn + fmts <- mapM getModificationTime fps + return $ any (> fmt) fmts + +getDirectoryContentsPath :: FilePath -> IO [ FilePath ] +getDirectoryContentsPath dp = do + fns <- getDirectoryContents dp + return $ map (( dp ++ "/" ) ++) fns diff --git a/src/Yavie.hs b/src/Yavie.hs new file mode 100644 --- /dev/null +++ b/src/Yavie.hs @@ -0,0 +1,16 @@ +module Yavie ( + + runYavie +, RefMonad +, YavieConfig(..) + +, defaultWithInitEditor +, defaultGetReadOnlyFlag + +, bind + +) where + +import Yavie.MainTools ( runYavie, YavieConfig(..), RefMonad, + defaultWithInitEditor, defaultGetReadOnlyFlag ) +import Control.EventDriven ( bind ) diff --git a/src/Yavie/Editor.hs b/src/Yavie/Editor.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/Editor.hs @@ -0,0 +1,666 @@ +module Yavie.Editor ( + +-- * Types + Editor +, Pos + +-- * Load to Editor, Save to file, Display Editor + +-- ** Load from and Save to file +, initialSaveToEditor +, saveToEditor + +, saveToFile +, saveToTmpFile + +-- ** Get value for Display +, isBoxCursor +, cursorPosOfDpy +, displayLines +, displayVisualLines + +-- ** Get Editor state +, fileName +, cursorPos + +-- ** Resize +, resizeDisplay + +-- * Move cursor + +-- ** Set cursor position +, cursorToXY + +-- ** Move vertical +, cursorUp +, cursorDown +, cursorToTop +, cursorToLine +, cursorToLinePercent +, cursorToHead +, cursorToMiddle +, cursorToLast + +-- ** Move horizontal +, cursorLeft +, cursorRight +, cursorTopOfLine +, cursorTopOfLineNotSpace +, cursorEndOfLine +, cursorFindChar +, cursorFindCharBack + +-- ** Move horizontal over lines +, cursorWord +, cursorWordEnd +, cursorBackWord + +, cursorSearchStr +, cursorNextSearchStr +, cursorSearchStrBack +, cursorNextSearchStrBack + +, resetStrForSearch +, addStrForSearch + +-- * Scroll +, scrollUp +, scrollDown +, scrollUpPage +, scrollDownPage +, scrollUpHPage +, scrollDownHPage +, scrollForCursorHead +, scrollForCursorMiddle +, scrollForCursorLast + +-- * Delete + +-- ** Delete vertical +, deleteUp +, deleteDown +, deleteLine +, deleteInLargeVmode + +, concatTwoLines + +-- ** Delete horizontal +, deleteLeft +, deleteRight +, deleteChar +, deleteCursorToEnd +, deleteCursorToBegin +, deleteFind +, deleteFindMore +, deleteFindBack + +-- ** Delete horizontal over lines +, deleteWord +, deleteWordEnd +, deleteBackWord + +-- * Insert +, insertString +, insertStringAfter +, insertChar +, insertNL + +, flipCase + +, inInsertMode +, outInsertMode + +, replaceModeOn +, replaceModeOff + +-- * Yank and Paste +, resetYank + +, yankLines +, yankInLargeVmode + +, pasteYanked +, pasteYankedAfter + +-- * Abount Undo etc +, saveToHistory +, undo +, redo + +, isModified +, resetModified + +-- * Visual mode +, setVisualBeginY +, resetVisualmode + +-- * Edit status bar +, resetStatus +, setStatus +, addStatus +, bsStatus + +, resetExCmd +, addExCmd +, getExCmd +, bsExCmd + +-- * Run multi times +, multi +, resetTimes +, addTimes + +-- * IO Action + +, resetIOAction +, setIOAction +, runIOAction + +-- * Delete Editor + +, needDeleteThisEditor +, deleteThisEditor + +-- * Other value + +, getOtherValue +, setOtherValue +, modifyOtherValue + +) where + +import Yavie.EditorCore hiding + ( runIOAction, saveToHistory, setIOAction, insertNL, insertChar, + inInsertMode, linesForDisplay, resetYank, concatTwoLines, + outInsertMode, pasteYanked, pasteYankedAfter, flipCase, + undo, redo, resetStatus, setStatus, addStatus, bsStatus, + isModified, resetModified, resizeMonitor, + getFileName, resetIOAction, + saveToTmpFile ) +import qualified Yavie.EditorCore as C + ( runIOAction, saveToHistory, setIOAction, insertNL, insertChar, + inInsertMode, linesForDisplay, resetYank, concatTwoLines, + outInsertMode, pasteYanked, pasteYankedAfter, flipCase, + undo, redo, resetStatus, setStatus, addStatus, bsStatus, + isModified, resetModified, resizeMonitor, + getFileName, resetIOAction, + saveToTmpFile ) +import Yavie.Tools +import Data.List ( elemIndices, findIndex ) +import Data.Char ( isDigit, isControl, isSpace ) +import Data.Maybe ( fromMaybe ) +import System.Directory + +type Pos = ( Int, Int ) + +cursorToXY :: Int -> Int -> Editor c -> Editor c +cursorToXY cx cy = cursorToX cx . cursorToLineN cy + +resetIOAction :: Editor c -> Editor c +resetIOAction = C.resetIOAction + +fileName :: Editor c -> FilePath +fileName = C.getFileName + +cursorPos :: Editor c -> Pos +cursorPos ed = ( getCursX ed, getCursY ed ) + +resizeDisplay :: Int -> Int -> Editor c -> Editor c +resizeDisplay = C.resizeMonitor + +isModified :: Editor c -> Bool +isModified = C.isModified + +resetModified :: Editor c -> Editor c +resetModified = C.resetModified + +resetStatus, bsStatus :: Editor c -> Editor c +resetStatus = C.resetStatus; bsStatus = C.bsStatus + +setStatus :: String -> Editor c -> Editor c +setStatus = C.setStatus + +addStatus :: Char -> Editor c -> Editor c +addStatus = C.addStatus + +undo, redo :: Editor c -> Editor c +undo = C.undo; redo = C.redo + +flipCase :: Editor c -> Editor c +flipCase = C.flipCase + +pasteYankedAfter :: Editor c -> Editor c +pasteYankedAfter = C.pasteYankedAfter + +pasteYanked :: Editor c -> Editor c +pasteYanked = C.pasteYanked + +outInsertMode :: Editor c -> Editor c +outInsertMode = C.outInsertMode + +concatTwoLines :: Editor c -> Editor c +concatTwoLines = C.concatTwoLines + +resetYank :: Editor c -> Editor c +resetYank = C.resetYank + +inInsertMode :: Editor c -> Editor c +inInsertMode = C.inInsertMode + +insertChar :: Char -> Editor c -> Editor c +insertChar = C.insertChar + +insertNL :: Editor c -> Editor c +insertNL = C.insertNL + +insertString, insertStringGen :: String -> Editor c -> Editor c +insertString str = insertStringGen str . saveToHistory +insertStringGen "" = id +insertStringGen ( '\n' : cs ) = insertStringGen cs . insertNL +insertStringGen ( c : cs ) = insertStringGen cs . cursorRight . insertChar c + +insertStringAfter :: String -> Editor c -> Editor c +insertStringAfter str = + outInsertMode . insertString str . cursorRight . inInsertMode + +saveToHistory :: Editor c -> Editor c +saveToHistory = C.saveToHistory + +setIOAction :: ( Editor c -> IO ( Editor c ) ) -> Editor c -> Editor c +setIOAction = C.setIOAction + +runIOAction :: Editor c -> IO ( Editor c ) +runIOAction = C.runIOAction + +type Editor c = EditorC ( Container c ) + +data Container c = Container { + cExCmd :: String , + cStrForSearch :: String , + cTimes :: Int , + cVisualBeginY :: Maybe Int , + cDeleteSelf :: Bool , + cReplaceMode :: Bool , + cOther :: Maybe c + } + +initContainer :: Container c +initContainer = Container { + cExCmd = "" , + cStrForSearch = "" , + cTimes = 0 , + cVisualBeginY = Nothing , + cDeleteSelf = False , + cReplaceMode = False , + cOther = Nothing + } + +cursorUp , cursorDown :: Editor c -> Editor c +cursorToTop , cursorToLine , cursorToLinePercent :: Editor c -> Editor c +cursorToHead, cursorToMiddle, cursorToLast :: Editor c -> Editor c + +cursorUp = moveToLine $ const3 (+ (-1)) +cursorDown = moveToLine $ const3 (+ 1) + +cursorToTop = moveToLine $ const4 0 +cursorToLine = scrollForCursorMiddle . + moveToLineT ( \n -> const2 . flip addIfMinus ( n - 1 ) ) +cursorToLinePercent = scrollForCursorMiddle . + moveToLineT ( \n -> const2 . (`div` 100) . (* n) ) + +cursorToHead = moveToLineT $ \n -> const2 (+ ( intoLargerEq 1 n - 1 )) +cursorToMiddle = moveToLine $ const $ \mh -> const . (+ mh `div` 2) +cursorToLast = moveToLineT $ \n _ mh -> (+ ( mh - intoLargerEq 1 n )) + +cursorToLineN :: Int -> Editor c -> Editor c +cursorToLineN n = moveToLine ( \_ _ _ _ -> n ) + +moveToLineT :: ( Int -> Int -> Int -> Int -> Int ) -> Editor c -> Editor c +moveToLineT f ed = let n = getTimes ed + ned = resetTimes ed + in moveToLine ( \bs mh my -> const $ f n bs mh my ) ned + +cursorToX :: Int -> Editor c -> Editor c +cursorToX x = moveInlineSimple $ const2 x + +cursorLeft , cursorRight :: Editor c -> Editor c +cursorTopOfLine, cursorTopOfLineNotSpace, cursorEndOfLine :: Editor c -> Editor c +cursorWord , cursorWordEnd , cursorBackWord :: Editor c -> Editor c +cursorFindChar , cursorFindCharBack :: Char -> Editor c -> Editor c + +cursorLeft = moveInlineSimple $ const (+ (-1)) +cursorRight = moveInlineSimple $ const (+ 1) + +cursorEndOfLine = moveInlineSimple $ const . (+ (-1)) . length +cursorTopOfLine = moveInlineSimple $ const2 0 +cursorTopOfLineNotSpace = + moveInlineSimple $ + \ln -> const $ fromMaybe ( lastIndex ln ) $ findIndex ( not . isSpace ) ln + +cursorWord = scrollForCursorIn . + outInsertMode . + moveToChar False False ( const $ not . isSpace ) . + moveToChar False False ( const isSpace ) . + inInsertMode +cursorWordEnd = scrollForCursorIn . + outInsertMode . + moveToChar True False ( const isSpace ) . + moveToChar True False ( const $ not . isSpace ) . + inInsertMode +cursorBackWord = scrollForCursorIn . + outInsertMode . + moveToChar True True ( const isSpace ) . + moveToChar True True ( const $ not . isSpace ) . + inInsertMode + +cursorFindChar = moveInline False False False . findChar +cursorFindCharBack = moveInline False False False . findCharBack + +moveInlineSimple :: ( String -> Int -> Int ) -> Editor c -> Editor c +moveInlineSimple f = + moveInline False False False ( \ln -> Just . f ln ) + +findChar, findCharMore, findCharBack :: Char -> String -> Int -> Maybe Int +findChar ch ln cx = let nxs = filter (> cx) $ elemIndices ch ln + in Just $ if null nxs then cx else head nxs +findCharMore ch ln cx = let nxs = filter (> cx) $ elemIndices ch ln + in Just $ if null nxs then cx else head nxs + 1 +findCharBack ch ln cx = let nxs = filter (< cx) $ elemIndices ch ln + in Just $ if null nxs then cx else last nxs + +cursorNextSearchStr, cursorSearchStr :: Editor c -> Editor c +cursorSearchStrBack, cursorNextSearchStrBack :: Editor c -> Editor c + +cursorSearchStr ed = scrollForCursorMiddleIfOut $ + moveInline False False True ( searchStr $ getStrForSearch ed ) ed +cursorNextSearchStr ed = scrollForCursorMiddleIfOut $ + moveInline True False True ( searchStr $ getStrForSearch ed ) ed + +cursorSearchStrBack ed = scrollForCursorMiddleIfOut $ + moveInline False True True ( searchStrBack $ getStrForSearch ed ) ed +cursorNextSearchStrBack ed = scrollForCursorMiddleIfOut $ + moveInline True True True ( searchStrBack $ getStrForSearch ed ) ed + +searchStr, searchStrBack :: String -> String -> Int -> Maybe Int +searchStr "" _ _ = Nothing +searchStr ss ln cx = let nxs = filter (>= cx) $ strIndices ss ln + in if null nxs then Nothing else Just $ head nxs +searchStrBack "" _ _ = Nothing +searchStrBack ss ln cx = let nxs = filter (<= cx) $ strIndices ss ln + in if null nxs then Nothing else Just $ last nxs + +scrollUp , scrollDown :: Editor c -> Editor c +scrollUpPage , scrollDownPage :: Editor c -> Editor c +scrollUpHPage , scrollDownHPage :: Editor c -> Editor c +scrollForCursorHead, scrollForCursorMiddle :: Editor c -> Editor c +scrollForCursorLast :: Editor c -> Editor c +scrollForCursorMiddleIfOut :: Editor c -> Editor c + +scrollUp = setMonitorY $ const2 (+ (-1)) +scrollDown = setMonitorY $ const2 (+ 1) +scrollUpPage = setMonitorY $ \mh -> const (+ (- mh )) +scrollDownPage = setMonitorY $ \mh -> const (+ mh ) +scrollUpHPage = setMonitorY $ \mh -> const (+ (- mh `div` 2)) +scrollDownHPage = setMonitorY $ \mh -> const (+ mh `div` 2) +scrollForCursorHead = setMonitorYT $ \n _ cy -> cy - n + 1 +scrollForCursorMiddle = setMonitorY $ \mh cy -> const $ cy - mh `div` 2 +scrollForCursorLast = setMonitorYT $ \n mh cy -> cy - mh + n +scrollForCursorMiddleIfOut = setMonitorY sfcmio + where + sfcmio mh cy my | cy < my || cy > my + mh - 1 = cy - mh `div` 2 + | otherwise = my + +setMonitorYT :: ( Int -> Int -> Int -> Int ) -> Editor c -> Editor c +setMonitorYT f ed = let n = intoLargerEq 1 $ getTimes ed + ned = resetTimes ed + in setMonitorY ( \mh cy _ -> f n mh cy ) ned + +deleteUp, deleteDown :: Editor c -> Editor c +deleteLine :: Editor c -> Editor c +deleteUp = deleteToLineT $ const3 . flip (-) +deleteDown = deleteToLineT $ const3 . (+) +deleteLine = deleteToLineT $ const3 . (+) . flip (-) 1 + +deleteInLargeVmode :: Editor c -> Editor c +deleteInLargeVmode ed = + case mvy of + Just vy -> modifyVisualBeginY ( const Nothing ) $ + deleteToLineT ( const5 vy ) ed + Nothing -> error "you are not in visual V mode" + where + mvy = getVisualBeginY ed + +deleteToLineT :: ( Int -> Int -> Int -> Int -> Int -> Int ) -> Editor c -> Editor c +deleteToLineT f ed = let t = intoLargerEq 1 $ getTimes ed + ned = resetTimes ed + in deleteToLine ( \bs mh my cy -> f t bs mh my cy ) ned + +deleteLeft, deleteRight :: Editor c -> Editor c +deleteChar :: Editor c -> Editor c +deleteLeft = deleteInline False False $ const $ Just . (+ (-1)) +deleteRight = deleteInline False False $ const $ Just . (+ 1) +deleteChar = deleteInline False False $ const $ Just . (+ 1) + +deleteCursorToEnd, deleteCursorToBegin :: Editor c -> Editor c +deleteCursorToEnd = deleteInline False False $ const . Just . length +deleteCursorToBegin = deleteInline False False $ const $ const $ Just 0 + +deleteFind, deleteFindMore, deleteFindBack :: Char -> Editor c -> Editor c +deleteFind = deleteInline False False . findChar +deleteFindMore = deleteInline False False . findCharMore +deleteFindBack = deleteInline False False . findCharBack + +deleteWord :: Editor c -> Editor c +deleteWord = deleteToChar False False ( const $ not . isSpace ) . + deleteToChar False False ( const isSpace ) + +deleteWordEnd :: Editor c -> Editor c +deleteWordEnd = deleteToChar False False ( const isSpace ) . + deleteToChar False False ( const $ not . isSpace ) + +deleteBackWord :: Editor c -> Editor c +deleteBackWord = deleteToChar True True ( const isSpace ) . + deleteToChar True True ( const $ not . isSpace ) + +initialSaveToEditor :: Int -> Int -> FilePath -> String -> Editor c +initialSaveToEditor = saveToEditorCore initContainer + +modifyCExCmd :: ( String -> String ) -> Container c -> Container c +modifyCExCmd f c@Container { cExCmd = ec } = c { cExCmd = f ec } + +modifyCStrForSearch :: ( String -> String ) -> Container c -> Container c +modifyCStrForSearch f c@Container { cStrForSearch = sfs } = + c { cStrForSearch = f sfs } + +modifyCTimes :: ( Int -> Int ) -> Container c -> Container c +modifyCTimes f c@Container { cTimes = t } = c { cTimes = f t } + +modifyCVisualBeginY :: ( Maybe Int -> Maybe Int ) -> Container c -> Container c +modifyCVisualBeginY f c@Container { cVisualBeginY = v } = c { cVisualBeginY = f v } + +setCVisualBeginY :: Int -> Container c -> Container c +setCVisualBeginY y c = c { cVisualBeginY = Just y } + +saveToTmpFile :: Editor c -> Editor c +saveToTmpFile ed = if isModified ed + then setIOAction C.saveToTmpFile ed + else ed + +saveToFile :: Editor c -> Editor c +saveToFile ed = if isModified ed + then setIOAction saveToFileC ed + else ed + +replaceModeOn, replaceModeOff :: Editor c -> Editor c +replaceModeOn = modifyContainer $ \c -> c { cReplaceMode = True } +replaceModeOff = modifyContainer $ \c -> c { cReplaceMode = False } + +isReplaceMode :: Editor c -> Bool +isReplaceMode = getsContainer cReplaceMode + +deleteThisEditor :: Editor c -> Editor c +deleteThisEditor = modifyContainer $ \c -> c { cDeleteSelf = True } + +needDeleteThisEditor :: Editor c -> Bool +needDeleteThisEditor = getsContainer cDeleteSelf + + +saveToEditor :: FilePath -> Editor c -> Editor c +saveToEditor fn = setIOAction ( editNextFileIfNeed fn ) + +editNextFileIfNeed :: String -> Editor c -> IO ( Editor c ) +editNextFileIfNeed fn ed = + do e <- doesFileExist fn + if e then do cnt <- readFile fn + return $ resaveToEditor fn cnt ed + else return $ deleteThisEditor + $ setStatus ( "not exist file " ++ fn ) ed + +resaveToEditor :: String -> String -> Editor c -> Editor c +resaveToEditor = resaveToEditorCore + +getVisualBeginYWithMonitorY :: ( Maybe Int -> Int -> a ) -> Editor c -> a +getVisualBeginYWithMonitorY = getsContainerWithMonitorY cVisualBeginY + +getVisualBeginY :: Editor c -> Maybe Int +getVisualBeginY = getsContainer cVisualBeginY + +modifyVisualBeginY :: ( Maybe Int -> Maybe Int ) -> Editor c -> Editor c +modifyVisualBeginY = modifyContainer . modifyCVisualBeginY + +resetVisualmode :: Editor c -> Editor c +resetVisualmode = modifyVisualBeginY $ const Nothing + +setVisualBeginY :: Editor c -> Editor c +setVisualBeginY = setToCursY setCVisualBeginY + +resetExCmd :: Editor c -> Editor c +resetExCmd = modifyContainer $ modifyCExCmd $ const "" + +addExCmd :: Char -> Editor c -> Editor c +addExCmd = modifyContainer . modifyCExCmd . flip (++) . (: []) + +bsExCmd :: Editor c -> Editor c +bsExCmd = modifyContainer $ modifyCExCmd init_ + +init_ :: [ a ] -> [ a ] +init_ [ ] = [ ] +init_ lst = init lst + +getExCmd :: Editor c -> String +getExCmd = getsContainer cExCmd + +getStrForSearch :: Editor c -> String +getStrForSearch = getsContainer cStrForSearch + +modifyStrForSearch :: ( String -> String ) -> Editor c -> Editor c +modifyStrForSearch = modifyContainer . modifyCStrForSearch + +getTimes :: Editor c -> Int +getTimes = getsContainer cTimes + +modifyTimes :: ( Int -> Int ) -> Editor c -> Editor c +modifyTimes = modifyContainer . modifyCTimes + +resetTimes :: Editor c -> Editor c +resetTimes = modifyTimes $ const 0 + +addTimes :: Char -> Editor c -> Editor c +addTimes c + | isDigit c = modifyTimes $ (+ read [ c ]) . (10 *) + | otherwise = error "first argument of addTimes is digit character" + +resetStrForSearch :: Editor c -> Editor c +resetStrForSearch = modifyStrForSearch $ const "" + +addStrForSearch :: Char -> Editor c -> Editor c +addStrForSearch = modifyStrForSearch . flip (++) . (: []) + +multi :: ( Editor c -> Editor c ) -> Editor c -> Editor c +multi f ed = + let t = getTimes ed + in resetTimes $ iterate f ed !! if t == 0 then 1 else t + +yankInLargeVmode :: Editor c -> Editor c +yankInLargeVmode ed = + case mvy of + Just vy -> modifyVisualBeginY ( const Nothing ) $ yankLinesCursTo vy ed + Nothing -> error "you are not in visual V mode" + where + mvy = getVisualBeginY ed + +yankLines :: Editor c -> Editor c +yankLines ed + = resetTimes $ yankLinesNum ( if t == 0 then 1 else t ) ed + where + t = getTimes ed + +data DisplayLines = DisplayLines { + isNotBoxCursorLFD :: Bool, + getCursorPosLFD :: ( Int, Int ), + displayLinesWithSelLFD :: [ ( Bool, String ) ] +} + +isBoxCursor :: Editor c -> Bool +isBoxCursor = not . isNotBoxCursorLFD . linesForDisplay + +cursorPosOfDpy :: Editor c -> Pos +cursorPosOfDpy = getCursorPosLFD . linesForDisplay + +displayVisualLines :: Editor c -> [ ( Bool, String ) ] +displayVisualLines = displayLinesWithSelLFD . linesForDisplay + +displayLines :: Editor c -> [ String ] +displayLines = displayLinesLFD . linesForDisplay + +displayLinesLFD :: DisplayLines -> [ String ] +displayLinesLFD = map snd . displayLinesWithSelLFD + +linesForDisplay :: Editor c -> DisplayLines +linesForDisplay ed = DisplayLines + ( isInsertMode ed && not ( isReplaceMode ed ) ) ( ncx, mcy ) ( ab linesGen ) + where + ( ( cx, mcy ), linesGen ) = C.linesForDisplay ed + ncx = tab2spaceN ( ctrl2str $ linesGen !! mcy ) $ + ctrl2strN ( linesGen !! mcy ) cx + mvy = getVisualBeginY ed + vyInMonitor = getVisualBeginYWithMonitorY ( \( Just v ) m -> v - m ) ed + cyInMonitor = getCursorYInMonitor ed + ab = addBool . splitLines . map ( map processCtrlChar . tab2space . ctrl2str ) + addBool ( pre, sel, aft ) = map ((,) False) pre ++ map ((,) True) sel + ++ map ((,) False) aft + splitLines lns = + maybe ( lns, [], [] ) + ( \_ -> if cyInMonitor <= vyInMonitor + then ( take ( cyInMonitor - 1 ) lns , + if cyInMonitor > 0 + then take ( vyInMonitor + 2 - cyInMonitor ) $ + drop ( cyInMonitor - 1 ) lns + else take vyInMonitor lns , + drop ( vyInMonitor + 1 ) lns ) + else ( take vyInMonitor lns , + if vyInMonitor > 0 + then take ( cyInMonitor - vyInMonitor ) $ + drop vyInMonitor lns + else take cyInMonitor lns , + drop cyInMonitor lns ) ) + mvy + processCtrlChar '\t' = ' ' + processCtrlChar c | isControl c = 'C' | otherwise = c + +getOtherValue :: Editor c -> Maybe c +getOtherValue = getsContainer cOther + +modifyCOther :: ( c -> c ) -> Container c -> Container c +modifyCOther m cnt@Container { cOther = Just co } = cnt { cOther = Just $ m co } +modifyCOther _ Container { cOther = Nothing } = error errStr + where errStr = "modifyCOther: set value before modify" + +setCOther :: c -> Container c -> Container c +setCOther v cnt = cnt { cOther = Just v } + +modifyOtherValue :: ( c -> c ) -> Editor c -> Editor c +modifyOtherValue = modifyContainer . modifyCOther + +setOtherValue :: c -> Editor c -> Editor c +setOtherValue = modifyContainer . setCOther diff --git a/src/Yavie/EditorCore.hs b/src/Yavie/EditorCore.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/EditorCore.hs @@ -0,0 +1,624 @@ +module Yavie.EditorCore ( + + EditorC + +, moveToLine +, moveInline +, moveToChar + +, resetYank + +, deleteToLine +, deleteInline +, deleteToChar + +, setMonitorY + +, insertChar +, insertNL + +, inInsertMode +, outInsertMode +, isInsertMode + +, yankToLine +, yankLinesCursTo +, yankLinesNum +, yankLinesFromTo + +, getCursX +, getCursY + +, saveToEditorCore +, resaveToEditorCore + +, moveCursorForCursorIn +, scrollForCursorIn + +, modifyContainer +, getsContainer +, getsContainerWithMonitorY +, getCursorYInMonitor + +, getFileName + +, linesForDisplay + +, resizeMonitor +, addEmptyIfNoLine + +, concatTwoLines + +, saveToHistory +, undo +, redo +, flipCase + +, pasteYanked +, pasteYankedAfter + +, getBufferContents +, lineNum + +, isModified +, resetModified + +, resetStatus +, setStatus +, addStatus +, bsStatus + +, setToCursY + +, resetIOAction +, setIOAction +, runIOAction + +, saveToFileC +, saveToTmpFile + +) where + +import Yavie.Tools ( lastIndex, inFromMToN, intoNToM, zeroToN, + opfs, takeXY, dropXY, reverseXY, findIndexXY ) +import Data.Maybe ( fromMaybe ) +import Data.Char ( isLower, isUpper, toLower, toUpper ) +import Control.Arrow ( first ) +import System.FilePath + +data EditorC c = Editor { + + fileName :: String , + buffer :: [ String ] , + status :: String , + cursXX :: Int , + cursX :: Int , + cursY :: Int , + monWidth :: Int , + monHeight :: Int , + monY :: Int , + + inlineYank :: Bool , + yankedLines :: [ String ] , + yankedString :: String , + + insertMode :: Bool , + + bufferHistory :: [ [ String ] ] , + redoHistory :: [ [ String ] ] , + udHistCur :: [ ( Int, Int ) ] , + crHistCur :: ( Int, Int ) , + rdHistCur :: [ ( Int, Int ) ] , + + modified :: Int , + + container :: c , + + exCommand :: EditorC c -> IO ( EditorC c ) , + + ioAction :: EditorC c -> IO ( EditorC c ) + + } + +type ToLineMoveRule = Int -> Int -> Int -> Int -> Int +type InlineMoveRule = String -> Int -> Maybe Int +type ToCharMoveRule = Char -> Char -> Bool +type BufferFun = [ String ] -> Int -> Int -> ( Int, Int ) + +intoLine :: EditorC c -> EditorC c +intoLine ed@Editor { cursX = cx } = + ed { cursX = inFromMToN ( minCurX ed ) ( maxCurX ed ) cx } + +setCursY :: Int -> EditorC c -> EditorC c +setCursY cy ed@Editor { buffer = buf, cursXX = cx } = scrollForCursorIn $ + intoLine ed { cursY = inFromMToN 0 ( lastIndex buf ) cy, cursX = cx } + +setCursPos :: Int -> Int -> EditorC c -> EditorC c +setCursPos cx cy ed = + intoLine ed { cursX = cx, cursXX = cx, + cursY = inFromMToN 0 ( lastIndex $ buffer ed ) cy } + +toEditorFun :: BufferFun -> EditorC c -> EditorC c +toEditorFun f ed@Editor { buffer = buf, cursX = cx, cursY = cy } = + uncurry setCursPos ( f buf cx cy ) ed + +moveToLine :: ToLineMoveRule -> EditorC c -> EditorC c +moveToLine f ed = + setCursY ( f ( numOfLines ed ) ( monHeight ed ) ( monY ed ) ( cursY ed ) ) ed + +moveInline :: Bool -> Bool -> Bool -> InlineMoveRule -> EditorC c -> EditorC c +moveInline next back wrap = toEditorFun . getInline next back wrap + +moveToChar :: Bool -> Bool -> ToCharMoveRule -> EditorC c -> EditorC c +moveToChar next back = toEditorFun . getToChar next back + +getInline :: Bool -> Bool -> Bool -> InlineMoveRule -> BufferFun +getInline next back wrap mv buf cx cy = fromMaybe ( cx, cy ) $ gi wrap ncx cy + where + ncx = if next then goNext cx else cx + goNext = if back then (+ (-1)) else (+ 1) + wrapped = if back then lastIndex buf else 0 + lineTop y = if back then lastIndex $ buf !! y else 0 + needWrap y = if back then y <= 0 else y >= lastIndex buf + gi w x y = case ( mv ( buf !! y ) x, mny ) of + ( Just nx, _ ) -> Just ( nx, y ) + ( _ , Just ny ) -> gi nw ( lineTop ny ) ny + _ -> Nothing + where + mny = case ( needWrap y, w ) of + ( False, _ ) -> Just $ goNext y + ( _ , True ) -> Just wrapped + _ -> Nothing + nw = w && not ( needWrap y ) + +getToChar :: + Bool -> Bool -> ToCharMoveRule -> [ String ] -> Int -> Int -> ( Int, Int ) +getToChar next back test buf = + curry $ renext . bufPos . uncurry ( gtc test nbuf ) . nbufPos . getnext + where + getnext = if next then uncurry nextPos else id + renext = if next then uncurry beforePos else id + nextPos = if back then getBackOverlineMore buf else getForwardOverline buf + beforePos = if back then getForwardOverline buf else getBackOverline buf + nbuf = if back then map ('\n':) buf else map (++"\n") buf + nbufPos = if back then first (+ 1) else id + bufPos = if back then first (+ (- 1)) else id + gtc p lns x y = newPos + where + newPos@( _, ny ) = ( baseX, y ) `addPos` dffPos + dffPos@( _, dy ) = fromMaybe ( 0, 0 ) $ + findIndexXY ( p $ lns !! y !! x ) field + field = if back then reverseXY $ takeXY ( x + 1 ) y lns + else dropXY x y lns + baseX = if dy == 0 then x else if back then lastX else 0 + lastX = lastIndex $ lns !! ny + addPos = if back then (-) `opfs` (-) else (+) `opfs` (+) + +resetYank :: EditorC c -> EditorC c +resetYank ed = ed { inlineYank = False, yankedLines = [ ], yankedString = "" } + +deleteToPos :: Int -> Int -> EditorC c -> EditorC c +deleteToPos nx ny ed@Editor { buffer = buf, cursX = cx, cursY = cy } = + ed { buffer = deleted, + inlineYank = True, + yankedString = yankedString ed ++ yanked, + cursY = nny, cursX = nnx } + where + ( deleted, yanked ) = getDeleteToPos cx cy nx ny buf + ( nny, nnx ) = min ( cy, cx ) ( ny, nx ) + +getDeleteToPos :: Int -> Int -> Int -> Int -> [ String ] + -> ( [ String ], String ) +getDeleteToPos xmin ymin xmax ymax buf + | ( ymin, xmin ) <= ( ymax, xmax ) = ( deleted, yanked ) + | otherwise = getDeleteToPos xmax ymax xmin ymin buf + where + deleted = take ymin buf ++ [ take xmin minLn ++ drop xmax maxLn ] + ++ drop ( ymax + 1 ) buf + yanked + | ymin == ymax = drop xmin $ take xmax minLn + | otherwise = init $ unlines $ drop xmin minLn : drop ( ymin + 2 ) ( take ymax buf ) + ++ [ take xmax maxLn ] + minLn = buf !! ymin + maxLn = buf !! ymax + +deleteToLine :: ToLineMoveRule -> EditorC c -> EditorC c +deleteToLine f ed = + let ny = f ( length $ buffer ed ) ( monHeight ed ) ( monY ed ) ( cursY ed ) + in deleteLinesFromTo ( cursY ed ) ny ed + +deleteLinesFromTo :: Int -> Int -> EditorC c -> EditorC c +deleteLinesFromTo y1 y2 ed@Editor { buffer = buf } + | y1 <= y2 = setCursY y1 + ed { buffer = take y1 buf ++ drop ( y2 + 1 ) buf , + yankedLines = drop y1 $ take ( y2 + 1 ) buf , + inlineYank = False } + | otherwise = deleteLinesFromTo y2 y1 ed + +deleteInline :: Bool -> Bool -> InlineMoveRule -> EditorC c -> EditorC c +deleteInline next back mv ed@Editor { buffer = buf, cursX = cx, cursY = cy } = + uncurry deleteToPos ( getInline next back False mv buf cx cy ) ed + +deleteToChar :: Bool -> Bool -> ToCharMoveRule -> EditorC c -> EditorC c +deleteToChar next backward p + ed@Editor { buffer = buf, cursX = cx, cursY = cy } = deleteToPos nx ny ed + where + cx_ = if next + then if backward then cx - 1 + else cx + 1 + else cx + ( nx_, ny ) = getToChar False backward p buf cx_ cy + nx = if next + then if backward then nx_ + 1 + else nx_ - 1 + else nx_ + +setMonitorY :: ( Int -> Int -> Int -> Int ) -> EditorC c -> EditorC c +setMonitorY f ed@Editor { buffer = buf, cursY = cy, monY = my, monHeight = mh } = + let nmy = ( if length buf > mh then zeroToN ( length buf - mh ) else const 0 ) $ + f mh cy my + in moveCursorForCursorIn ed { monY = nmy } + +saveToEditorCore :: c -> Int -> Int -> String -> String -> EditorC c +saveToEditorCore c w h fn cnt = Editor { + + buffer = if null cnt then [ "" ] else lines cnt , + bufferHistory = [ ] , + udHistCur = [ ] , + crHistCur = ( 0, 0 ) , + redoHistory = [ ] , + rdHistCur = [ ] , + fileName = fn , + status = "" , + cursXX = 0 , + cursX = 0 , + cursY = 0 , + monWidth = w , + monHeight = h - 1 , + monY = 0 , + + inlineYank = False , + yankedLines = [ ] , + yankedString = "" , + + insertMode = False , + + modified = 0 , + + container = c , + + exCommand = return , + ioAction = return + + } + +setIOAction :: + ( EditorC c -> IO ( EditorC c ) ) -> EditorC c -> EditorC c +setIOAction io ed = ed { ioAction = io } + +runIOAction :: EditorC c -> IO ( EditorC c ) +runIOAction ed = fmap resetIOAction $ ioAction ed ed + +resetIOAction :: EditorC c -> EditorC c +resetIOAction ed = ed { ioAction = return } + +saveToTmpFile :: EditorC c -> IO ( EditorC c ) +saveToTmpFile ed = do + let lns = lineNum ed + fn = getFileName ed + putStr $ take ( lns - lns ) "dummy" + writeFile ( takeDirectory fn ++ "/.yavie." ++ takeFileName fn ) ( getBufferContents ed ) + return $ setStatus "written tmp" ed + +saveToFileC :: EditorC c -> IO ( EditorC c ) +saveToFileC ed = + do let lns = lineNum ed + putStr $ take ( lns - lns ) "dummy" + writeFile ( getFileName ed ) ( getBufferContents ed ) + return $ setStatus "written" $ resetModified ed + +resaveToEditorCore :: String -> String -> EditorC c -> EditorC c +resaveToEditorCore fn cnt ed = ed { + + buffer = if null cnt then [ "" ] else lines cnt , + fileName = fn , + + bufferHistory = [ ] , + udHistCur = [ ] , + crHistCur = ( 0, 0 ) , + redoHistory = [ ] , + rdHistCur = [ ] , + + status = "new file " ++ fn , + cursXX = if fileName ed == fn then cursX ed else 0 , + cursX = if fileName ed == fn then cursXX ed else 0 , + cursY = if fileName ed == fn then cursY ed else 0 , + + monY = if fileName ed == fn then monY ed else 0 , + + modified = 0 + + } + +getFileName :: EditorC c -> String +getFileName = fileName + +getBackOverline, getBackOverlineMore, getForwardOverline :: + [ String ] -> Int -> Int -> ( Int, Int ) + +getBackOverlineMore _ (-1) 0 = ( -1, 0 ) +getBackOverlineMore _ 0 0 = ( -1, 0 ) +getBackOverlineMore buf (-1) cy = let nx = length $ buf !! ( cy - 1 ) + in ( nx, cy - 1 ) +getBackOverlineMore _ cx cy = ( cx - 1, cy ) + +getBackOverline _ (-1) 0 = ( -1, 0 ) +getBackOverline _ 0 0 = ( -1, 0 ) +getBackOverline buf 0 cy = let nx = length $ buf !! ( cy - 1 ) + in ( nx, cy - 1 ) +getBackOverline _ cx cy = ( cx - 1, cy ) + +getForwardOverline buf cx cy + | cy == length buf && cx == length ( buf !! cy ) = ( cx , cy ) + | cx == length ( buf !! cy ) = ( 0 , cy + 1 ) + | otherwise = ( cx + 1, cy ) + +modifyContainer :: ( c -> c ) -> EditorC c -> EditorC c +modifyContainer f ed@Editor { container = c } = ed { container = f c } + +getsContainer :: ( c -> a ) -> EditorC c -> a +getsContainer f = f . container + +getsContainerWithMonitorY :: ( c -> a ) -> ( a -> Int -> b ) -> EditorC c -> b +getsContainerWithMonitorY f op Editor { monY = my, container = c } = + op ( f c ) my + +getCursorYInMonitor :: EditorC c -> Int +getCursorYInMonitor Editor { cursY = cy, monY = my } = cy - my + 1 + +scrollForCursorIn :: EditorC c -> EditorC c +scrollForCursorIn = setMonitorY cursorIn + where cursorIn mh cy = intoNToM ( cy - mh + 1 ) cy + +moveCursorForCursorIn :: EditorC c -> EditorC c +moveCursorForCursorIn ed@Editor { cursY = cy, monHeight = mh, monY = my } + | cy < my = setCursY my ed + | cy > my + mh - 1 = setCursY ( my + mh - 1 ) ed + | otherwise = ed + +linesForDisplay :: EditorC c -> ( ( Int, Int ), [ String ] ) +linesForDisplay Editor + { buffer = buf, status = stat, cursX = cx, cursY = cy, + monHeight = mh, monY = my, monWidth = mw } = + ( ( cx, cy - my ), + addToNA mh "" ( take mh ( drop my buf ) ) ++ [ statLn ] ) + where + prcnt = if length buf > mh then my * 100 `div` ( length buf - mh ) else 100 + statLn = stat ++ addToNB ( mw - length stat - 16 ) ' ' + ( show ( cy + 1 ) ++ "," ++ show ( cx + 1 ) ) + ++ addToNB 16 ' ' ( show prcnt ++ "%" ) + addToNB n x xs = replicate ( n - length xs ) x ++ xs + addToNA n x xs = xs ++ replicate ( n - length xs ) x + +resizeMonitor :: Int -> Int -> EditorC c -> EditorC c +resizeMonitor w h ed = ed { monWidth = w, monHeight = h } + +addEmptyIfNoLine :: EditorC c -> EditorC c +addEmptyIfNoLine ed@Editor { buffer = [ ] } = ed { buffer = [ "" ] } +addEmptyIfNoLine ed = ed + +concatTwoLines :: EditorC c -> EditorC c +concatTwoLines ed@Editor { buffer = buf, cursY = cy } + = ed { buffer = take cy buf ++ + [ buf !! cy ++ buf !! ( cy + 1 ) ] ++ + drop ( cy + 2 ) buf } + +insertChar :: Char -> EditorC c -> EditorC c +insertChar ch ed@Editor { buffer = buf, cursX = cx, cursY = cy } + = let thisLn = buf !! cy + ned = ed { buffer = take cy buf ++ + [ take cx thisLn ++ [ ch ] ++ drop cx thisLn ] ++ + drop ( cy + 1 ) buf , + cursX = if cx < 0 then 1 else cx + 1 , + cursXX = cursX ned } + in ned + +insertNL :: EditorC c -> EditorC c +insertNL ed@Editor { buffer = buf, cursX = cx, cursY = cy } + = let thisLn = buf !! cy + ned = ed { buffer = take cy buf ++ + [ take cx thisLn, drop cx thisLn ] ++ + drop ( cy + 1 ) buf , + cursX = 0 , + cursY = cy + 1 , + cursXX = cursX ned } + in scrollForCursorIn ned + +yankToLine :: ToLineMoveRule -> EditorC c -> EditorC c +yankToLine = error "yet" + +yankLinesCursTo :: Int -> EditorC c -> EditorC c +yankLinesCursTo ny ed@Editor { cursY = cy } + = yankLinesFromTo cy ny ed + +yankLinesNum :: Int -> EditorC c -> EditorC c +yankLinesNum ln ed@Editor { cursY = cy } + = yankLinesCursTo ( cy + ln - 1 ) ed + +yankLinesFromTo :: Int -> Int -> EditorC c -> EditorC c +yankLinesFromTo y1 y2 ed@Editor { buffer = buf } + | y1 >= y2 = ed { yankedLines = take ( y1 - y2 + 1 ) $ drop y2 buf, + inlineYank = False } + | otherwise = ed { yankedLines = take ( y2 - y1 + 1 ) $ drop y1 buf, + inlineYank = False } + +saveToHistory :: EditorC c -> EditorC c +saveToHistory ed@Editor + { buffer = buf, bufferHistory = bufHst, + cursX = cx, cursY = cy, udHistCur = uhc, modified = m } = + ed { bufferHistory = buf : bufHst, udHistCur = ( cx, cy ) : uhc , + redoHistory = [], rdHistCur = [], + modified = m + 1 } + +undo :: EditorC c -> EditorC c +undo ed@Editor + { buffer = buf, bufferHistory = bufHst, redoHistory = rdHst , + udHistCur = uhc, rdHistCur = rhc, crHistCur = chc , + modified = m } = + if not $ null bufHst + then scrollForCursorIn $ + ed { buffer = head bufHst , + bufferHistory = tail bufHst , + redoHistory = buf : rdHst , + cursX = fst $ head uhc, cursY = snd $ head uhc , + crHistCur = head uhc, + udHistCur = tail uhc, rdHistCur = chc : rhc , + modified = m - 1 } + else ed + +redo :: EditorC c -> EditorC c +redo ed@Editor + { buffer = buf, bufferHistory = bufHst, redoHistory = rdHst , + udHistCur = uhc, rdHistCur = rhc, crHistCur = chc , + modified = m } = + if not $ null rdHst + then scrollForCursorIn $ + ed { buffer = head rdHst , + bufferHistory = buf : bufHst , + redoHistory = tail rdHst, + cursX = fst chc, cursY = snd chc , + crHistCur = head rhc , + udHistCur = chc : uhc, rdHistCur = tail rhc , + modified = m + 1 } + else ed + +flipCase :: EditorC c -> EditorC c +flipCase ed@Editor { buffer = buf, cursX = cx, cursY = cy } + = let thisLn = buf !! cy + in ed { buffer = + take cy buf ++ + [ take cx thisLn ++ [ fc ( thisLn !! cx ) ] + ++ drop ( cx + 1 ) thisLn ] ++ + drop ( cy + 1 ) buf } + where + fc c | isUpper c = toLower c + | isLower c = toUpper c + | otherwise = c + +pasteYankedInline :: EditorC c -> EditorC c +pasteYankedInline ed@Editor { buffer = buf, cursY = cy, cursX = cx } + = ed { buffer = nbuf } + where + thisLn = buf !! cy + y = lines_ $ yankedString ed + nbuf = case y of + [ ] -> error "yet" + [ sy ] -> take cy buf ++ [ take cx thisLn ++ sy ++ drop cx thisLn ] + ++ drop ( cy + 1 ) buf + ( fy : ry ) -> take cy buf ++ [ take cx thisLn ++ fy ] + ++ init ry + ++ [ last ry ++ drop cx thisLn ] + ++ drop ( cy + 1 ) buf + +lines_ :: String -> [ String ] +lines_ = splitBy '\n' + +splitBy :: Eq a => a -> [ a ] -> [ [ a ] ] +splitBy _ [ ] = [ ] +splitBy x xs = takeWhile (/= x) xs : splitBy x ( tailIfX $ dropWhile (/= x) xs ) + where + tailIfX ( y : ys ) | x == y = ys + tailIfX ya = ya + +pasteYankedInlineAfter :: EditorC c -> EditorC c +pasteYankedInlineAfter ed@Editor { buffer = buf, cursY = cy, cursX = cx } + = let thisLn = buf !! cy + in ed { buffer = take cy buf ++ + [ take ( cx + 1 ) thisLn ++ y ++ drop ( cx + 1 ) thisLn ] ++ + drop ( cy + 1 ) buf } + where + y = yankedString ed + +getCursX, getCursY :: EditorC c -> Int +getCursX = cursX +getCursY = cursY + +getBufferContents :: EditorC c -> String +getBufferContents Editor { buffer = buf } = unlines buf + +lineNum :: EditorC c -> Int +lineNum = length . buffer + +pasteYankedLine :: EditorC c -> EditorC c +pasteYankedLine ed@Editor { buffer = buf } + = ed { buffer = take cy buf ++ y ++ drop cy buf } + where + cy = getCursY ed + y = yankedLines ed + +pasteYankedLineAfter :: EditorC c -> EditorC c +pasteYankedLineAfter ed@Editor { buffer = buf } + = ed { buffer = take ( cy + 1 ) buf ++ y ++ drop ( cy + 1 ) buf } + where + cy = getCursY ed + y = yankedLines ed + +pasteYanked :: EditorC c -> EditorC c +pasteYanked ed = + if inlineYank ed then pasteYankedInline ed + else pasteYankedLine ed + +pasteYankedAfter :: EditorC c -> EditorC c +pasteYankedAfter ed = + if inlineYank ed then pasteYankedInlineAfter ed + else pasteYankedLineAfter ed + +isModified :: EditorC c -> Bool +isModified = (0 /=) . modified + +resetModified :: EditorC c -> EditorC c +resetModified ed = ed { modified = 0 } + +addStatus :: Char -> EditorC c -> EditorC c +addStatus ch ed@Editor { status = stat } = ed { status = stat ++ [ ch ] } + +bsStatus :: EditorC c -> EditorC c +bsStatus ed@Editor { status = stat } = ed { status = init_ stat } + +init_ :: [ a ] -> [ a ] +init_ [ ] = [ ] +init_ [ x ] = [ x ] +init_ lst = init lst + +resetStatus :: EditorC c -> EditorC c +resetStatus ed = ed { status = "" } + +setStatus :: String -> EditorC c -> EditorC c +setStatus str ed = ed { status = str } + +setToCursY :: ( Int -> c -> c ) -> EditorC c -> EditorC c +setToCursY f ed@Editor { cursY = cy, container = c } = + ed { container = f cy c } + +inInsertMode, outInsertMode :: EditorC c -> EditorC c +inInsertMode ed = ed { insertMode = True } +outInsertMode ed = intoLine $ ed { insertMode = False } +isInsertMode :: EditorC c -> Bool +isInsertMode = insertMode + +maxCurX :: EditorC c -> Int +maxCurX ed@Editor { insertMode = im } + | im = length $ cursorLine ed + | otherwise = lastIndex $ cursorLine ed + +minCurX :: EditorC c -> Int +minCurX ed@Editor { insertMode = im } + | im = -1 + | null $ cursorLine ed = -1 + | otherwise = 0 + +numOfLines :: EditorC c -> Int +numOfLines Editor { buffer = buf } = length buf + +cursorLine :: EditorC c -> String +cursorLine Editor { buffer = buf, cursY = cy } = buf !! cy diff --git a/src/Yavie/Keybind.hs b/src/Yavie/Keybind.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/Keybind.hs @@ -0,0 +1,39 @@ +module Yavie.Keybind ( + + Keybind +, Cmdbind + +, Event(..) +, Key(..) +, Modifier(..) +, Button(..) + +) where + +import Control.EventDriven +import Yavie.Editor + +data Event = EvKey Key [ Modifier ] + | EvMouse Int Int Button [ Modifier ] + | EvResize Int Int + | EvExpose + | EvDeleteEditor + | UnknownEvent + +data Key = + KEsc + | KFun Int + | KBS | KDel | KIns | KTab | KBackTab | KEnter + | KUp | KDown | KLeft | KRight + | KHome | KEnd | KPageUp | KPageDown + | KMenu | KPause | KPrtScr + | KASCII Char + | KOthers Int + | KUnknown + +data Modifier = MShift | MCtrl | MAlt | MMeta + +data Button = BLeft | BMiddle | BRight + +type Keybind c = Event -> EventMonad Event ( Editor c ) () +type Cmdbind c = String -> EventMonad Event ( Editor c ) () diff --git a/src/Yavie/Keybind/Vi.hs b/src/Yavie/Keybind/Vi.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/Keybind/Vi.hs @@ -0,0 +1,388 @@ +module Yavie.Keybind.Vi ( + + defaultKeybind +, defaultCmdbind +, defaultRomode + +, defaultInsertmode + +) where + +import Control.EventDriven + ( EventMonad, bind, unbind, runEvent, delegate, + copyContainer, removeContainer ) +import Yavie.Editor + ( Editor, multi, needDeleteThisEditor, deleteThisEditor, + cursorUp, cursorDown, + cursorToTop, cursorToLine, cursorToLinePercent, + cursorToHead, cursorToMiddle, cursorToLast, + cursorLeft, cursorRight, + cursorTopOfLineNotSpace, cursorTopOfLine, cursorEndOfLine, + cursorFindChar, cursorFindCharBack, + cursorWord, cursorWordEnd, cursorBackWord, + resetStrForSearch, addStrForSearch, + cursorSearchStr, cursorSearchStrBack, + cursorNextSearchStr, cursorNextSearchStrBack, + scrollUp, scrollDown, scrollUpPage, scrollDownPage, + scrollUpHPage, scrollDownHPage, + scrollForCursorHead, scrollForCursorMiddle, scrollForCursorLast, + resetYank, + deleteUp, deleteDown, deleteLine, + deleteLeft, deleteRight, deleteChar, + deleteCursorToBegin, deleteCursorToEnd, + deleteWord, deleteWordEnd, deleteBackWord, + deleteFind, deleteFindMore, + concatTwoLines, + yankLines, + insertChar, insertNL, flipCase, + inInsertMode, outInsertMode, + pasteYanked, pasteYankedAfter, + setVisualBeginY, resetVisualmode, deleteInLargeVmode, yankInLargeVmode, + resizeDisplay, + saveToHistory, undo, redo, + resetTimes, addTimes, + resetStatus, setStatus, addStatus, bsStatus, + resetExCmd, addExCmd, getExCmd, bsExCmd, + saveToFile, + saveToTmpFile, + isModified, + saveToEditor, + fileName, + replaceModeOn, replaceModeOff ) +import Control.Monad.State ( modify, gets, when ) +import Data.Char ( isDigit ) +import Yavie.Keybind + +saveHistory :: + EventMonad Event ( Editor c ) () -> EventMonad Event ( Editor c ) () +saveHistory = (modify saveToHistory >>) + +key :: Char -> EventMonad Event ( Editor c ) () +key ch = runEvent ( EvKey ( KASCII ch ) [ ] ) + +toInsertmode :: EventMonad Event ( Editor c ) () +toInsertmode = saveHistory $ + modify ( setStatus "insert mode" ) >> modify inInsertMode >> bind insertmode >> + modify saveToTmpFile + +deleteEditorIfNeed :: EventMonad Event ( Editor c ) () +deleteEditorIfNeed = do + d <- gets needDeleteThisEditor + when d removeContainer + +defaultRomode :: Keybind c +defaultRomode ( EvKey ( KASCII c ) [ ] ) + | c `elem` "iIaArRdDcCsSoO" = return () +defaultRomode e = defaultKeybind defaultCmdbind e + +defaultKeybind :: Cmdbind c -> Keybind c +defaultKeybind _ EvExpose = return () +defaultKeybind _ ( EvKey ( KASCII 'u' ) [ ] ) = modify undo +defaultKeybind _ ( EvKey ( KASCII 'r' ) [ MCtrl ] ) = modify redo +defaultKeybind _ ( EvKey ( KASCII 'j' ) [ ] ) = modify $ multi cursorDown +defaultKeybind _ ( EvKey ( KASCII 'k' ) [ ] ) = modify $ multi cursorUp +defaultKeybind _ ( EvKey ( KASCII 'H' ) [ ] ) = modify cursorToHead +defaultKeybind _ ( EvKey ( KASCII 'M' ) [ ] ) = modify cursorToMiddle +defaultKeybind _ ( EvKey ( KASCII 'L' ) [ ] ) = modify cursorToLast +defaultKeybind _ ( EvKey ( KASCII 'l' ) [ ] ) = modify $ multi cursorRight +defaultKeybind _ ( EvKey ( KASCII 'h' ) [ ] ) = modify $ multi cursorLeft +defaultKeybind _ ( EvKey ( KASCII '$' ) [ ] ) = modify cursorEndOfLine +defaultKeybind _ ( EvKey ( KASCII '0' ) [ ] ) = modify cursorTopOfLine +defaultKeybind _ ( EvKey ( KASCII '^' ) [ ] ) = modify cursorTopOfLineNotSpace +defaultKeybind _ ( EvKey ( KASCII 'w' ) [ ] ) = modify $ multi cursorWord +defaultKeybind _ ( EvKey ( KASCII 'b' ) [ ] ) = modify $ multi cursorBackWord +defaultKeybind _ ( EvKey ( KASCII 'e' ) [ ] ) = modify $ multi cursorWordEnd +defaultKeybind _ ( EvKey ( KASCII 'f' ) [ ] ) = bind findmode +defaultKeybind _ ( EvKey ( KASCII 'F' ) [ ] ) = bind findbackmode +defaultKeybind _ ( EvKey ( KASCII 'e' ) [ MCtrl ] ) = + modify $ multi scrollDown +defaultKeybind _ ( EvKey ( KASCII 'y' ) [ MCtrl ] ) = + modify $ multi scrollUp +defaultKeybind _ ( EvKey ( KASCII 'f' ) [ MCtrl ] ) = + modify $ multi scrollDownPage +defaultKeybind _ ( EvKey ( KASCII 'b' ) [ MCtrl ] ) = + modify $ multi scrollUpPage +defaultKeybind _ ( EvKey ( KASCII 'd' ) [ MCtrl ] ) = + modify $ multi scrollDownHPage +defaultKeybind _ ( EvKey ( KASCII 'u' ) [ MCtrl ] ) = + modify $ multi scrollUpHPage +defaultKeybind _ ( EvKey ( KASCII 'x' ) [ ] ) = saveHistory $ + modify resetYank >> modify ( multi deleteChar ) +defaultKeybind _ ( EvKey ( KASCII 'X' ) [ ] ) = saveHistory $ + modify $ multi ( deleteChar . cursorLeft ) +defaultKeybind _ ( EvKey ( KASCII 'i' ) [ ] ) = toInsertmode +defaultKeybind _ ( EvKey ( KASCII 'I' ) [ ] ) = modify cursorTopOfLineNotSpace >> key 'i' +defaultKeybind _ ( EvKey ( KASCII 'a' ) [ ] ) = toInsertmode >> + modify cursorRight +defaultKeybind _ ( EvKey ( KASCII 'A' ) [ ] ) = toInsertmode >> + modify cursorEndOfLine >> modify cursorRight +defaultKeybind _ ( EvKey ( KASCII 'o' ) [ ] ) = + toInsertmode >> modify cursorEndOfLine >> modify cursorRight + >> modify insertNL +defaultKeybind _ ( EvKey ( KASCII 'O' ) [ ] ) = + modify cursorTopOfLine >> modify insertNL + >> modify cursorUp >> toInsertmode +defaultKeybind _ ( EvKey ( KASCII 'r' ) [ ] ) = + saveHistory $ bind replacemodeOne +defaultKeybind _ ( EvKey ( KASCII '~' ) [ ] ) = saveHistory $ + modify flipCase >> key 'l' +defaultKeybind _ ( EvKey ( KASCII 'R' ) [ ] ) = saveHistory $ + modify inInsertMode >> modify replaceModeOn >> bind replacemode +defaultKeybind _ ( EvKey ( KASCII 's' ) [ ] ) = toInsertmode >> + modify ( multi deleteChar ) +defaultKeybind _ ( EvKey ( KASCII 'S' ) [ ] ) = + modify cursorTopOfLine >> modify deleteCursorToEnd + >> toInsertmode +defaultKeybind _ ( EvKey ( KASCII 'J' ) [ ] ) = saveHistory $ + modify cursorEndOfLine >> modify concatTwoLines +defaultKeybind _ ( EvKey ( KASCII 'D' ) [ ] ) = saveHistory $ + modify deleteCursorToEnd +defaultKeybind _ ( EvKey ( KASCII 'd' ) [ ] ) = saveHistory $ + modify resetYank >> bind deletemode +defaultKeybind _ ( EvKey ( KASCII 'C' ) [ ] ) = saveHistory $ modify inInsertMode >> + modify deleteCursorToEnd >> key 'i' +defaultKeybind _ ( EvKey ( KASCII 'c' ) [ ] ) = saveHistory $ bind changemode +defaultKeybind _ ( EvKey ( KASCII 'y' ) [ ] ) = bind yankmode +defaultKeybind _ ( EvKey ( KASCII 'p' ) [ ] ) = saveHistory $ modify pasteYankedAfter +defaultKeybind _ ( EvKey ( KASCII 'P' ) [ ] ) = saveHistory $ modify pasteYanked +defaultKeybind _ ( EvKey ( KASCII 'G' ) [ ] ) = + modify cursorToLine +defaultKeybind _ ( EvKey ( KASCII '%' ) [ ] ) = modify cursorToLinePercent +defaultKeybind _ ( EvKey ( KASCII 'g' ) [ ] ) = bind gomode +defaultKeybind cb ( EvKey ( KASCII 'Z' ) [ ] ) = bind $ lzmode cb +defaultKeybind _ ( EvKey ( KASCII 'z' ) [ ] ) = bind zmode +defaultKeybind _ ( EvKey ( KASCII c ) [ ] ) + | isDigit c = do modify resetTimes + modify $ addTimes c + bind digitmode +defaultKeybind _ ( EvKey ( KASCII 'V' ) [ ] ) = do + modify setVisualBeginY + modify $ setStatus "V mode" + bind visualVmode +defaultKeybind cb ( EvKey ( KASCII ':' ) [ ] ) = do + modify resetStatus + modify $ addStatus ':' + modify resetExCmd + bind $ exmode cb +defaultKeybind _ ( EvKey ( KASCII 'n' ) [ ] ) = + modify cursorNextSearchStr +defaultKeybind _ ( EvKey ( KASCII 'N' ) [ ] ) = + modify cursorNextSearchStrBack +defaultKeybind _ ( EvKey ( KASCII '/' ) [ ] ) = do + modify resetStatus + modify $ addStatus '/' + modify resetStrForSearch + bind $ searchmode False +defaultKeybind _ ( EvKey ( KASCII '?' ) [ ] ) = do + modify resetStatus + modify $ addStatus '?' + modify resetStrForSearch + bind $ searchmode True +defaultKeybind _ ( EvResize w h ) = + modify $ resizeDisplay w $ h - 1 +defaultKeybind _ EvDeleteEditor = deleteEditorIfNeed +defaultKeybind _ _ = return () + +searchmode :: Bool -> Event -> EventMonad Event ( Editor c ) () +searchmode _ ( EvKey ( KASCII c ) [ MMeta ] ) = do + _ <- runEvent $ EvKey KEsc [ ] + runEvent $ EvKey ( KASCII c ) [ ] +searchmode _ ( EvKey KEsc [ ] ) = do + _ <- unbind + modify resetStatus +searchmode _ ( EvKey KEnter [ ] ) = do + _ <- unbind + modify resetStatus +searchmode d ( EvKey ( KASCII c ) [ ] ) = do + modify $ addStrForSearch c + modify $ addStatus c + modify $ if d then cursorSearchStrBack else cursorSearchStr +searchmode _ _ = delegate + +findmode, findbackmode :: Event -> EventMonad Event ( Editor c ) () +findmode ( EvKey ( KASCII c ) [ ] ) = + unbind >> modify ( multi $ cursorFindChar c ) +findmode _ = return () +findbackmode ( EvKey ( KASCII c ) [ ] ) = + unbind >> modify ( multi $ cursorFindCharBack c ) +findbackmode _ = return () + +defaultInsertmode, insertmode, replacemodeOne, replacemode :: Keybind c + +defaultInsertmode = insertmode + +insertmode ( EvKey ( KASCII c ) [ MMeta ] ) = + runEvent ( EvKey KEsc [ ] ) >> runEvent ( EvKey ( KASCII c ) [ ] ) +insertmode ( EvKey KEsc [ ] ) = + modify resetStatus >> unbind >> modify cursorLeft >> modify outInsertMode +insertmode ( EvKey ( KASCII c ) [ ] ) = + modify ( insertChar c ) +insertmode ( EvKey KEnter [ ] ) = + modify insertNL +insertmode _ = delegate + +replacemodeOne ( EvKey ( KASCII c ) [ ] ) = + modify inInsertMode >> + modify ( multi $ insertChar c . deleteChar ) >> unbind >> modify cursorLeft + >> modify outInsertMode +replacemodeOne _ = return () + +replacemode ( EvKey ( KASCII c ) [ MMeta ] ) = + runEvent ( EvKey KEsc [ ] ) >> key c +replacemode ( EvKey KEsc [ ] ) = + modify resetStatus >> unbind >> modify cursorLeft >> modify replaceModeOff + >> modify outInsertMode +replacemode ( EvKey ( KASCII c ) [ ] ) = + modify deleteChar >> modify ( insertChar c ) +replacemode ( EvKey KEnter [ ] ) = + modify deleteChar >> modify insertNL +replacemode _ = delegate + +deletemode, yankmode, changemode, gomode :: Event -> EventMonad Event ( Editor c ) () + +deletemode ( EvKey ( KASCII 'k' ) [ ] ) = modify deleteUp >> unbind +deletemode ( EvKey ( KASCII 'j' ) [ ] ) = modify deleteDown >> unbind +deletemode ( EvKey ( KASCII 'h' ) [ ] ) = modify ( multi deleteLeft ) >> unbind +deletemode ( EvKey ( KASCII 'l' ) [ ] ) = modify ( multi deleteRight ) >> unbind +deletemode ( EvKey ( KASCII 'd' ) [ ] ) = modify deleteLine >> unbind +deletemode ( EvKey ( KASCII 'w' ) [ ] ) = modify ( multi deleteWord ) >> unbind +deletemode ( EvKey ( KASCII 'e' ) [ ] ) = modify ( multi deleteWordEnd ) >> unbind +deletemode ( EvKey ( KASCII 'b' ) [ ] ) = modify ( multi deleteBackWord ) >> unbind +deletemode ( EvKey ( KASCII '0' ) [ ] ) = modify deleteCursorToBegin >> unbind +deletemode ( EvKey ( KASCII '$' ) [ ] ) = modify deleteCursorToEnd >> unbind +deletemode ( EvKey ( KASCII 'f' ) [ ] ) = + bind deletefmode +deletemode ( EvKey ( KASCII 't' ) [ ] ) = + bind deletetmode +deletemode ( EvKey ( KASCII _ ) [ ] ) = unbind +deletemode _ = delegate + +deletefmode, deletetmode, changefmode, changetmode :: + Event -> EventMonad Event ( Editor c ) () + +deletefmode ( EvKey ( KASCII c ) [ ] ) = do + modify $ multi $ deleteFindMore c + unbind >> unbind +deletefmode ( EvKey _ _ ) = unbind >> unbind +deletefmode _ = delegate + +deletetmode ( EvKey ( KASCII c ) [ ] ) = do + modify $ multi $ deleteFind c + unbind >> unbind +deletetmode (EvKey _ _ ) = unbind >> unbind +deletetmode _ = delegate + +changefmode ( EvKey ( KASCII c ) [ ] ) = do + modify $ multi $ deleteFindMore c + _ <- unbind >> unbind + key 'i' +changefmode ( EvKey _ _ ) = unbind >> unbind +changefmode _ = delegate + +changetmode ( EvKey ( KASCII c ) [ ] ) = do + modify $ multi $ deleteFind c + _ <- unbind >> unbind + key 'i' +changetmode ( EvKey _ _ ) = unbind >> unbind +changetmode _ = delegate + +yankmode ( EvKey ( KASCII 'y' ) [ ] ) = modify yankLines >> unbind +yankmode ( EvKey _ _ ) = unbind +yankmode _ = delegate + +changemode ( EvKey ( KASCII 'w' ) [ ] ) = + modify ( multi deleteWord ) >> unbind >> key 'i' +changemode ( EvKey ( KASCII 'e' ) [ ] ) = + modify ( multi deleteWordEnd ) >> unbind >> key 'i' +changemode ( EvKey ( KASCII 'b' ) [ ] ) = + modify ( multi deleteBackWord ) >> unbind >> key 'i' +changemode ( EvKey ( KASCII '$' ) [ ] ) = + modify inInsertMode >> modify deleteCursorToEnd >> unbind + >> key 'i' +changemode ( EvKey ( KASCII '0' ) [ ] ) = + modify deleteCursorToBegin >> unbind >> key 'i' +changemode ( EvKey ( KASCII 'c' ) [ ] ) = + modify cursorTopOfLine >> modify deleteCursorToEnd >> unbind >> key 'i' +changemode ( EvKey ( KASCII 'f' ) [ ] ) = bind changefmode +changemode ( EvKey ( KASCII 't' ) [ ] ) = bind changetmode +changemode ( EvKey _ _ ) = unbind +changemode _ = delegate + +gomode ( EvKey ( KASCII 'g' ) [ ] ) = + modify cursorToTop >> unbind +gomode ( EvKey ( KASCII _ ) [ ] ) = unbind +gomode _ = delegate + + +lzmode :: Cmdbind c -> Keybind c +lzmode cb ( EvKey ( KASCII 'Z' ) [ ] ) = unbind >> cb "wq" +lzmode _ ( EvKey _ _ ) = unbind +lzmode _ _ = delegate + +zmode :: Keybind c +zmode ( EvKey ( KASCII '.' ) [ ] ) = + unbind >> modify scrollForCursorMiddle +zmode ( EvKey KEnter [ ] ) = + unbind >> modify scrollForCursorHead +zmode ( EvKey ( KASCII '-' ) [ ] ) = + unbind >> modify scrollForCursorLast +zmode ( EvKey _ _ ) = unbind +zmode _ = delegate + +digitmode :: Event -> EventMonad Event ( Editor c ) () +digitmode ( EvKey ( KASCII c ) [ ] ) + | isDigit c = modify $ addTimes c + | otherwise = unbind >> runEvent ( EvKey ( KASCII c ) [ ] ) +digitmode EvDeleteEditor = delegate +digitmode ev = unbind >> runEvent ev + +exmode :: Cmdbind c -> Keybind c +exmode _ ( EvKey ( KASCII c ) [ MMeta ] ) = do + _ <- runEvent $ EvKey KEsc [ ] + runEvent $ EvKey ( KASCII c ) [ ] +exmode _ ( EvKey KEsc [ ] ) = do + _ <- unbind + modify resetStatus +exmode cb ( EvKey KEnter [ ] ) = do + _ <- unbind + modify resetStatus + cmd <- gets getExCmd + modify resetExCmd + cb cmd +exmode _ ( EvKey ( KASCII 'h' ) [ MCtrl ] ) = do + modify bsStatus + modify bsExCmd +exmode _ ( EvKey ( KASCII c ) [ ] ) = do + modify $ addStatus c + modify $ addExCmd c +exmode _ _ = return () + +defaultCmdbind :: Cmdbind c +defaultCmdbind "q" = do + m <- gets isModified + if m then modify ( setStatus "modified! use wq or q!" ) + else removeContainer +defaultCmdbind "q!" = removeContainer +defaultCmdbind "w" = modify saveToFile +defaultCmdbind "wq" = do + modify saveToFile + modify deleteThisEditor +defaultCmdbind "e!" = do + fn <- gets fileName + modify $ saveToEditor fn +defaultCmdbind ( 'e' : ' ' : fn ) = do + _ <- copyContainer + modify $ saveToEditor fn +defaultCmdbind cmd = modify $ setStatus $ cmd ++ " is not valid ex command" + +visualVmode :: Event -> EventMonad Event ( Editor c ) () +visualVmode ( EvKey ( KASCII c ) [ MMeta ] ) = + runEvent ( EvKey KEsc [ ] ) >> runEvent ( EvKey ( KASCII c ) [ ] ) +visualVmode ( EvKey KEsc [ ] ) = modify resetVisualmode >> unbind +visualVmode ( EvKey ( KASCII 'y' ) [ ] ) = do + modify yankInLargeVmode + unbind +visualVmode ( EvKey ( KASCII 'd' ) [ ] ) = saveHistory $ do + modify deleteInLargeVmode + unbind +visualVmode _ = delegate diff --git a/src/Yavie/MainTools.hs b/src/Yavie/MainTools.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/MainTools.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module Yavie.MainTools ( + + defaultWithInitEditor +, getOptions +, getCmdLns +, defaultGetReadOnlyFlag +, UI(..) +, Pos + +, YavieConfig(..) +, runYavie +, RefMonad + +) where + +import Yavie.Editor +import Yavie.Keybind +import Yavie.Tools + +import Control.EventDriven + ( getEventValue, EventState, initEvent, putEvent ) +import System.Directory +import Control.Monad +import System.Console.GetOpt ( getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..) ) +import System.Environment +import Data.Maybe +import System.FilePath +import Data.IORef + +class RefMonad m a where + type Ref m :: * -> * + newRef :: a -> m ( Ref m a ) + readRef :: Ref m a -> m a + writeRef :: Ref m a -> a -> m () + +instance RefMonad IO a where + type Ref IO = IORef + newRef = newIORef + readRef = readIORef + writeRef = writeIORef + +getContainer :: ( Monad m, RefMonad m ( EventState e c )) => + Ref m ( EventState e c ) -> m c +getContainer = liftM getEventValue . readRef + +withCursorPos :: FilePath -> ( Pos -> IO ( Editor c ) ) -> IO () +withCursorPos fn action = runWithFileCursor $ \fc -> do + let pos = fromMaybe ( 0, 0 ) $ lookup fn fc + action pos + +runWithFileCursor :: ( [ ( FilePath, Pos ) ] -> IO ( Editor c ) ) -> IO () +runWithFileCursor action = do + home <- fmap (++"/.yjedit/") getHomeDirectory + createDirectoryIfMissing False home + let bcFile = home ++ "/buffer_cursor_xy.txt" + e <- doesFileExist bcFile + unless e $ writeFile bcFile "" + fc <- getFileCursor + ret <- action fc + putFileCursor $ updateFileCursor ret fc + +getFileCursor :: IO [ ( FilePath, Pos ) ] +getFileCursor = do + home <- getHomeDirectory + let fn = home ++ "/.yjedit/buffer_cursor_xy.txt" + cnt <- readFile fn + putStr $ take ( length cnt - length cnt ) "dummy" + return $ map ( \ln -> let [ f, x, y ] = words ln + in ( f, ( read x, read y ) ) ) $ lines cnt + +updateFileCursor :: Editor c -> [ ( FilePath, Pos ) ] -> [ ( FilePath, Pos ) ] +updateFileCursor ed fc = + ( fileName ed, cursorPos ed ) : filter ( (/=fileName ed) . fst ) fc + +putFileCursor :: [ ( FilePath, Pos ) ] -> IO () +putFileCursor fc = do + home <- getHomeDirectory + let fn = home ++ "/.yjedit/buffer_cursor_xy.txt" + writeFile fn $ unlines $ + map ( \( f, ( x, y ) ) -> f ++ " " ++ show x ++ " " ++ show y ) fc + +data CmdLnOption = OptGtk | OptX11 | OptRO | OptDemo deriving ( Eq, Show ) +data UI = UIGtk | UIX11 | UIVty deriving Show + +getOptions :: IO ( UI, Bool, Bool, Maybe String ) +getOptions = do + options <- getArgs + let ( opts, args, _err ) = getOpt Permute optDescrs options + ui = if OptGtk `elem` opts + then UIGtk + else if OptX11 `elem` opts + then UIX11 else UIVty + ro = elem OptRO opts + demo = elem OptDemo opts || null args + fn = listToMaybe args + return ( ui, ro, demo, fn ) + +optDescrs :: [ OptDescr CmdLnOption ] +optDescrs = [ optDescrX11, optDescrRO, optDescrDemo, optDescrGtk ] +optDescrX11, optDescrRO, optDescrDemo, optDescrGtk :: OptDescr CmdLnOption +optDescrX11 = Option "x" [ "x11" ] ( NoArg OptX11 ) "use X11" +optDescrRO = Option "R" [ ] ( NoArg OptRO ) "read only" +optDescrDemo = Option "" [ "demo" ] ( NoArg OptDemo ) "demo" +optDescrGtk = Option "g" [ "gtk" ] ( NoArg OptGtk ) "use gtk" + +defaultGetReadOnlyFlag :: IO Bool +defaultGetReadOnlyFlag = do + ( _, ro, _, _, _, _ ) <- getCmdLns + return ro + +getCmdLns :: IO ( UI, Bool, Bool, Bool, FilePath, String ) +getCmdLns = do + ( ui, ro, demo, mfn ) <- getOptions + fn <- case mfn of + Just fn_ -> mkAbsoluteFilePath fn_ + Nothing -> mkAbsoluteFilePath ".yavie.NONAME" + ex <- doesFileExist fn + cnt <- if ex then readFile fn else return "" + putStr $ take ( length cnt - length cnt ) "dummy" + return ( ui, ro, demo, ex, fn, cnt ) + +defaultWithInitEditor :: Int -> Int -> ( Editor c -> IO ( Editor c ) ) -> IO () +defaultWithInitEditor iw ih action = do + ( _, _, _, ex, fn, cnt ) <- getCmdLns + let status = if ex then show $ takeFileName fn + else show ( takeFileName fn ) ++ " [New file]" + withCursorPos fn $ \( cx, cy ) -> do + let initEditor = scrollForCursorMiddle $ cursorToXY cx cy $ setStatus status + $ initialSaveToEditor iw ih fn cnt + action initEditor + +data YavieConfig m iface c = YavieConfig { + + isEventDriven :: Bool , + + withInitEditor :: Int -> Int -> ( Editor c -> m ( Editor c ) ) -> m () , + displaySize :: iface -> m ( Int, Int ) , + + initialize :: m iface , + supplyEvent :: iface -> ( Event -> m Bool ) -> m () , + finalize :: iface -> m () , + + drawDisplay :: iface -> m ( Editor c ) -> m () , + + keybind :: Keybind c , + romode :: Keybind c , + getReadOnlyFlag :: m Bool , + + runAction :: Editor c -> m ( Editor c ) + + } + +runYavie :: ( Monad m, RefMonad m ( EventState Event ( Editor c ) ) ) => + YavieConfig m iface c -> m () +runYavie cfg = do + iface <- initialize cfg + ( w, h ) <- displaySize cfg iface + ro <- getReadOnlyFlag cfg + let kb = if ro then romode cfg else keybind cfg + + withInitEditor cfg w h $ \initEditor -> do + talkerRef <- newRef $ initEvent initEditor kb + drawDisplay cfg iface ( {- liftM linesForDisplay $ -} + if isEventDriven cfg then getContainer talkerRef + else return initEditor ) + supplyEvent cfg iface $ \ev -> do + tk <- readRef talkerRef + mtk <- putEvent + ( \ed -> do + ned <- runAction cfg ed + drawDisplay cfg iface + ( {- liftM linesForDisplay $ -} + if isEventDriven cfg then getContainer talkerRef + else return ned ) + return ned ) + tk ev + case mtk of + Nothing -> return False + Just ntk -> do + mntk <- putEvent return ntk EvDeleteEditor + case mntk of + Nothing -> return False + Just nntk -> writeRef talkerRef nntk >> return True + getContainer talkerRef + finalize cfg iface diff --git a/src/Yavie/Tools.hs b/src/Yavie/Tools.hs new file mode 100644 --- /dev/null +++ b/src/Yavie/Tools.hs @@ -0,0 +1,164 @@ +module Yavie.Tools ( + + const2 +, const3 +, const4 +, const5 +, addIfMinus + +, ctrl2strN +, ctrl2str +, tab2spaceN +, tab2space + +, inFromMToN +, zeroToN +, intoMToN +, intoNToM + +, intoLargerEq + +, strIndices + +, lastIndex + +, reverseXY +, findIndexXY +, takeXY +, dropXY + +, opfs + +, normalizeTwoDot +, mkAbsoluteFilePath + +) where + +import Data.List ( isPrefixOf, isInfixOf, findIndex ) +import Data.Char ( isControl, ord ) +import System.FilePath ( normalise, combine ) +import System.Directory ( getCurrentDirectory ) +import Numeric ( showHex ) +import Text.RegexPR ( gsubRegexPR ) + +const2 :: a -> b -> c -> a +const2 = const . const + +const3 :: a -> b -> c -> d -> a +const3 = const . const . const + +const4 :: a -> b -> c -> d -> e -> a +const4 = const . const . const . const + +const5 :: a -> b -> c -> d -> e -> f -> a +const5 = const . const . const . const . const + +addIfMinus :: ( Num a, Ord a ) => a -> a -> a +addIfMinus a x | x < 0 = x + a + | otherwise = x + + +isCtrl :: Char -> Bool +isCtrl c = isControl c && ( c /= '\t' ) + +ctrl2str :: String -> String +ctrl2str "" = "" +ctrl2str ( c : cs ) + | isCtrl c = '\\' : showHex2 ( ord c ) ++ ctrl2str cs + | otherwise = c : ctrl2str cs + where + showHex2 n = let s = showHex n "" in replicate ( 2 - length s ) '0' ++ s + +ctrl2strN :: String -> Int -> Int +ctrl2strN _ 0 = 0 +ctrl2strN "" n = n +ctrl2strN ( c : cs ) n + | isCtrl c = 3 + ctrl2strN cs ( n - 1 ) + | otherwise = 1 + ctrl2strN cs ( n - 1 ) + +tab2spaceN :: String -> Int -> Int +tab2spaceN = t2sn 8 + +t2sn :: Int -> String -> Int -> Int +t2sn _ _ 0 = 0 +t2sn _ "" n = n +t2sn i ( '\t' : cs ) n = i + t2sn 8 cs ( n - 1 ) +t2sn i ( _ : cs ) n + | i > 1 = 1 + t2sn ( i - 1 ) cs ( n - 1 ) + | otherwise = 1 + t2sn 8 cs ( n - 1 ) + +tab2space :: String -> String +tab2space = t2s 8 + +t2s :: Int -> String -> String +t2s _ "" = "" +t2s i ( '\t' : cs ) = replicate i ' ' ++ t2s 8 cs +t2s i ( c : cs ) + | i > 1 = c : t2s ( i - 1 ) cs + | otherwise = c : t2s 8 cs + +zeroToN :: ( Num a, Ord a ) => a -> a -> a +zeroToN n x | x < 0 && 0 <= n = 0 + | 0 <= n && n < x = n + | x < n && n < 0 = n + | n < 0 && 0 < x = 0 + | otherwise = x + +intoMToN :: ( Num a, Ord a ) => a -> a -> a -> a +intoMToN = intoNToM + +intoNToM :: ( Num a, Ord a ) => a -> a -> a -> a +intoNToM n m x | x < n && n <= m = n + | n <= m && m < x = m + | x < m && m < n = m + | m < n && n < x = n + | otherwise = x + +intoLargerEq :: Ord a => a -> a -> a +intoLargerEq m n | n < m = m + | otherwise = n + +strIndices :: Eq a => [ a ] -> [ a ] -> [ Int ] +strIndices _ [ ] = [ ] +strIndices str field@( _ : next ) + | str `isPrefixOf` field = 0 : map (+ 1) ( strIndices str next ) + | otherwise = map (+ 1) ( strIndices str next ) + +inFromMToN :: ( Num a, Ord a ) => a -> a -> a -> a +inFromMToN m n x + | m <= n && n < x = n + | x < m && m <= n = m + | m <= n = x + | otherwise = error "inFromMToN: need m <= n" + +lastIndex :: [ a ] -> Int +lastIndex = (+ (-1)) . length + +reverseXY :: [ [ a ] ] -> [ [ a ] ] +reverseXY = map reverse . reverse + +findIndexXY :: ( a -> Bool ) -> [ [ a ] ] -> Maybe ( Int, Int ) +findIndexXY _ [ ] = Nothing +findIndexXY p ( ln : lns ) = + case ( findIndex p ln, findIndexXY p lns ) of + ( Just i, _ ) -> Just ( i, 0 ) + ( _ , Just ( x, y ) ) -> Just ( x, y + 1 ) + _ -> Nothing + +takeXY, dropXY :: Int -> Int -> [ [ a ] ] -> [ [ a ] ] +takeXY xx yy ll = take yy ll ++ [ take xx ( ll !! yy ) ] +dropXY xx yy ll = drop xx ( ll !! yy ) : drop ( yy + 1 ) ll + +opfs :: + ( a -> b -> c ) -> ( a' -> b' -> c' ) -> ( a, a' ) -> ( b, b' ) -> ( c, c' ) +opfs opf ops ( x, y ) ( x', y' ) = ( x `opf` x', y `ops` y' ) + +normalizeTwoDot :: FilePath -> FilePath +normalizeTwoDot fp + | ".." `isInfixOf` fp = normalizeTwoDot $ gsubRegexPR "/[^/]+/\\.\\./" "/" fp + | otherwise = fp + +mkAbsoluteFilePath :: FilePath -> IO FilePath +mkAbsoluteFilePath fp = do + cd <- getCurrentDirectory + return $ normalizeTwoDot $ normalise $ cd `combine` fp diff --git a/src/gtk/yavie-gtk.cabal b/src/gtk/yavie-gtk.cabal new file mode 100644 --- /dev/null +++ b/src/gtk/yavie-gtk.cabal @@ -0,0 +1,9 @@ +build-type: Simple +cabal-version: >= 1.2 + +name: yavie-gtk +version: 0.0.1 + +executable yavie-gtk + main-is: yavie-gtk.hs + build-depends: base > 4, cairo >= 0.11, gtk >= 0.11, yavie diff --git a/src/gtk/yavie-gtk.hs b/src/gtk/yavie-gtk.hs new file mode 100644 --- /dev/null +++ b/src/gtk/yavie-gtk.hs @@ -0,0 +1,113 @@ +module Main ( main ) where + +import Yavie +import Yavie.Editor +import Yavie.Keybind +import Yavie.Keybind.Vi + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.GC +import Graphics.Rendering.Cairo +import Control.Monad ( unless ) + +myConfig :: YavieConfig IO ( Window, DrawingArea, IMContext, PangoLayout ) () +myConfig = YavieConfig { + withInitEditor = defaultWithInitEditor , + initialize = initializeGtk , + finalize = runGtk , + displaySize = const $ return ( 60, 19 ) , + supplyEvent = \ifc pe -> onImContextCommit ifc pe >> onKeyPressEvent ifc pe , + drawDisplay = onCanvasExposeEvent , + keybind = defaultKeybind defaultCmdbind , + romode = defaultRomode , + getReadOnlyFlag = defaultGetReadOnlyFlag , + runAction = runIOAction , + isEventDriven = True + } + +runGtk :: ( Window, DrawingArea, IMContext, PangoLayout ) -> IO () +runGtk ( win, _, _, _ ) = do + widgetShowAll win + mainGUI + +onImContextCommit :: + ( Window, DrawingArea, IMContext, PangoLayout ) -> ( Event -> IO Bool ) -> IO () +onImContextCommit ( _, canvas, im, _ ) pe = do + _ <- on im imContextCommit $ \str -> do + mapM_ ( \c -> pe $ EvKey ( KASCII c ) [ ] ) str + widgetQueueDraw canvas + return () + +onKeyPressEvent :: + ( Window, DrawingArea, IMContext, PangoLayout ) -> ( Event -> IO Bool ) -> IO () +onKeyPressEvent ( window, canvas, im, _ ) pe = do + _ <- on window keyPressEvent $ do + imHandled <- imContextFilterKeypress im + if imHandled then return True else do + keyNam <- eventKeyName + keyChar <- fmap keyToChar eventKeyVal + liftIO $ case ( keyChar, keyNam ) of + ( Just c, _ ) -> do _ <- pe $ EvKey ( KASCII c ) [ ] + widgetQueueDraw canvas + ( _, "Return" ) -> do conti <- pe $ EvKey KEnter [ ] + unless conti mainQuit + widgetQueueDraw canvas + ( _, "Escape" ) -> do _ <- pe $ EvKey KEsc [ ] + widgetQueueDraw canvas + _ -> return () + return True + return () + +onCanvasExposeEvent :: + ( Window, DrawingArea, IMContext, PangoLayout ) -> IO ( Editor c ) -> IO () +onCanvasExposeEvent ( _, canvas, _, lay ) lnsGen = do + _ <- on canvas exposeEvent $ do + win <- eventWindow + gc <- liftIO $ gcNew win + liftIO $ do + dl <- lnsGen + let ins = isBoxCursor dl + crs = cursorPosOfDpy dl + lns = displayLines dl + layoutSetText lay $ unlines lns + PangoRectangle cx cy cw ch <- + layoutIndexToPos lay ( uncurry ( xyToN lns ) crs ) + let cw_ = if ins then cw else 0 + drawRectangle win gc False ( round cx ) ( round cy ) ( round cw_ ) (round ch ) + renderWithDrawable win $ do + moveTo 0 0 + showLayout lay + return True + return () + +initializeGtk :: IO ( Window, DrawingArea, IMContext, PangoLayout ) +initializeGtk = do + pc <- cairoCreateContext Nothing +-- contextSetTextGravity pc PangoGravityEast + lay <- layoutText pc "おはよう" + + _ <- initGUI + window <- windowNew + im <- imMulticontextNew + vbox <- vBoxNew True 1 + frame <- frameNew + canvas <- drawingAreaNew + set window [ containerChild := vbox ] + boxPackStart vbox frame PackGrow 0 + containerAdd frame canvas + widgetModifyBg canvas StateNormal ( Color 65535 65535 65535 ) + _ <- onDestroy window mainQuit + _ <- on window realize $ imContextSetClientWindow im . Just =<< + widgetGetDrawWindow window + _ <- on window focusInEvent $ liftIO ( imContextFocusIn im ) >> return False + return ( window, canvas, im, lay ) + +main :: IO () +main = runYavie myConfig + +xyToN :: [ String ] -> Int -> Int -> Int +xyToN _ x 0 = if x < 0 then 0 else x +xyToN [ ] _ _ = error "xyToN: cursor y is over" +xyToN ( ln : lns ) x y + | y > 0 = ( length ln + 1 ) + xyToN lns x ( y - 1 ) + | otherwise = error "xyToN: cursor y is negative value" diff --git a/src/vty/yavie-vty.cabal b/src/vty/yavie-vty.cabal new file mode 100644 --- /dev/null +++ b/src/vty/yavie-vty.cabal @@ -0,0 +1,9 @@ +build-type: Simple +cabal-version: >= 1.2 + +name: yavie-vty +version: 0.0.1 + +executable yavie-vty + main-is: yavie-vty.hs + build-depends: monads-tf, old-locale, time, yavie, yjtools, vty, base > 4 diff --git a/src/vty/yavie-vty.hs b/src/vty/yavie-vty.hs new file mode 100644 --- /dev/null +++ b/src/vty/yavie-vty.hs @@ -0,0 +1,117 @@ +module Main ( main ) where + +import Graphics.Vty + ( Vty, Cursor(..), DisplayRegion(..), + Event(..), Key(..), Modifier(..), Button(..), + mkVty, shutdown, update, next_event, display_bounds, terminal, + pic_for_image, pic_cursor, string, vert_cat, + with_style, def_attr, reverse_video ) +import Control.Monad.Tools + +import Yavie +import Yavie.Editor +import Yavie.Keybind ( Cmdbind ) +import qualified Yavie.Keybind as K +import Yavie.Keybind.Vi +import Data.Time +import System.Locale +import Control.Monad.State + +main :: IO () +main = runYavie myConfig + +myCmdbind :: Cmdbind () +myCmdbind "today" = do + bind defaultInsertmode + modify $ setIOAction $ \ed -> do + time <- getToday + return $ insertStringAfter ( "\n\n" ++ time ++ "\n" ) + $ cursorEndOfLine ed + where + getToday = do + tz <- getCurrentTimeZone + lDay <- fmap ( localDay . utcToLocalTime tz ) getCurrentTime + return $ formatTime defaultTimeLocale "%Y.%m.%d %a." lDay +myCmdbind cmd = defaultCmdbind cmd + + +myConfig :: YavieConfig IO Vty () +myConfig = YavieConfig { + + isEventDriven = False , + + withInitEditor = defaultWithInitEditor , + initialize = mkVty , + finalize = shutdown , + displaySize = getDisplaySize , + drawDisplay = drawDisplayVty , + + supplyEvent = \vty act -> doWhile_ $ + fmap convertEvent ( next_event vty ) >>= act , + + keybind = defaultKeybind myCmdbind , + romode = defaultRomode , + + runAction = runIOAction , + getReadOnlyFlag = defaultGetReadOnlyFlag + +} + +getDisplaySize :: Vty -> IO ( Int, Int ) +getDisplaySize vty = do + DisplayRegion w h <- display_bounds $ terminal vty + return ( fromIntegral w, fromIntegral h ) + +drawDisplayVty :: Vty -> IO ( Editor c ) -> IO () +drawDisplayVty vty getLns = do + ed <- getLns + let ( cx, cy ) = cursorPosOfDpy ed + lns = displayVisualLines ed + img = vert_cat $ map ( \( s, ln ) -> string ( getAttr s ) $ ln ++ " " ) lns + pic = ( pic_for_image img ) { pic_cursor = Cursor ( fromIntegral cx ) + ( fromIntegral cy ) } + update vty pic + where + getAttr True = def_attr `with_style` reverse_video + getAttr False = def_attr + +convertEvent :: Event -> K.Event +convertEvent ( EvKey k ms ) = + K.EvKey ( convertKey k ) ( map convertModifier ms ) +convertEvent ( EvMouse x y b ms ) = + K.EvMouse x y ( convertButton b ) ( map convertModifier ms ) +convertEvent ( EvResize w h ) = K.EvResize w h + +convertKey :: Key -> K.Key +convertKey KEsc = K.KEsc +convertKey ( KFun n ) = K.KFun n +convertKey ( KASCII '\t' ) = K.KTab +convertKey KBackTab = K.KBackTab +convertKey KPrtScr = K.KPrtScr +convertKey KPause = K.KPause +convertKey ( KASCII c ) = K.KASCII c +convertKey KBS = K.KBS +convertKey KIns = K.KIns +convertKey KHome = K.KHome +convertKey KPageUp = K.KPageUp +convertKey KDel = K.KDel +convertKey KEnd = K.KEnd +convertKey KPageDown = K.KPageDown +convertKey KNP5 = K.KUnknown +convertKey KUp = K.KUp +convertKey KMenu = K.KMenu +convertKey KLeft = K.KLeft +convertKey KDown = K.KDown +convertKey KRight = K.KRight +convertKey KEnter = K.KEnter + +convertModifier :: Modifier -> K.Modifier +convertModifier MShift = K.MShift +convertModifier MCtrl = K.MCtrl +convertModifier MMeta = K.MMeta +convertModifier MAlt = K.MAlt + +convertButton :: Button -> K.Button +convertButton BLeft = K.BLeft +convertButton BMiddle = K.BMiddle +convertButton BRight = K.BRight diff --git a/src/x11/yavie-x11.cabal b/src/x11/yavie-x11.cabal new file mode 100644 --- /dev/null +++ b/src/x11/yavie-x11.cabal @@ -0,0 +1,10 @@ +build-type: Simple +cabal-version: >= 1.2 + +name: yavie-x11 +version: 0.0.1 + +executable yavie-x11 + main-is: yavie-x11.hs + build-depends: base > 4, convertible, time, setlocale, yjtools, x11-xim, + X11, X11-xft, yavie diff --git a/src/x11/yavie-x11.hs b/src/x11/yavie-x11.hs new file mode 100644 --- /dev/null +++ b/src/x11/yavie-x11.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main ( main ) where + +import Yavie +import Yavie.Editor +import Yavie.Keybind +import Yavie.Keybind.Vi + +import Graphics.X11 +import Graphics.X11.Xft +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xim +import Data.Bits +import Control.Monad ( zipWithM_, when, unless ) +import Control.Monad.Tools + +import Data.IORef -- just hack +import System.IO.Unsafe +import System.Exit +import System.Locale.SetLocale +import Data.Time +import Data.Maybe +import Data.Convertible +import Foreign.C.Types + +myConfig :: YavieConfig IO XVars () +myConfig = YavieConfig { + + isEventDriven = False , + + withInitEditor = defaultWithInitEditor , + initialize = initializeX11 , + finalize = finalizeX11 , + displaySize = const $ return ( 60, 24 ) , + drawDisplay = drawDisplayX11 , + supplyEvent = \xvars act -> doWhile_ $ getEventX11 xvars >>= act , + + keybind = defaultKeybind defaultCmdbind , + romode = defaultRomode , + runAction = runIOAction , + getReadOnlyFlag = defaultGetReadOnlyFlag + + } + +main :: IO () +main = runYavie myConfig + +font, color :: String +font = "Kochi Gothic-12:style=Regular" +color = "black" + +type XVars = + ( Display, Window, Visual, Colormap, XftDraw, XftFont, XIC, Atom, IORef String ) + +initializeX11 :: IO XVars +initializeX11 = do + + inbuf <- newIORef "" + + ret <- setLocale LC_CTYPE Nothing + case ret of + Nothing -> putStrLn "Can't set locale." >> exitFailure + Just r -> print r + sl <- supportsLocale + unless sl $ putStrLn "Current locale is notSupported." >> exitFailure + _ <- setLocaleModifiers "" + + dpy <- openDisplay "" + delWin <- internAtom dpy "WM_DELETE_WINDOW" True + let scr = defaultScreen dpy + black = blackPixel dpy scr + white = whitePixel dpy scr + scrN = defaultScreenOfDisplay dpy + visual = defaultVisual dpy scr + colormap = defaultColormap dpy scr + rootWin <- rootWindow dpy scr + win <- createSimpleWindow dpy rootWin 0 0 100 100 1 black white + setWMProtocols dpy win [ delWin ] + im <- openIM dpy Nothing Nothing Nothing + ic <- createIC im [ XIMPreeditNothing, XIMStatusNothing ] win + fevent <- getICValue ic "filterEvents" + xftDraw <- xftDrawCreate dpy win visual colormap + xftFont <- xftFontOpen dpy scrN font + mapWindow dpy win + selectInput dpy win $ keyPressMask .|. exposureMask .|. fevent + let xvars = ( dpy, win, visual, colormap, xftDraw, xftFont, ic, delWin, inbuf ) + + return xvars + +finalizeX11 :: XVars -> IO () +finalizeX11 ( dpy, _, _, _, _, xftFont, _, _, _ ) = do + xftFontClose dpy xftFont + closeDisplay dpy + +nextNotFilteredEvent :: Display -> XEventPtr -> IO () +nextNotFilteredEvent dpy e = do + nextEvent dpy e + filtOut <- filterEvent e 0 + when filtOut $ nextNotFilteredEvent dpy e + +evpToEvent :: ( Convertible CInt a, Eq a ) => + IORef String -> XIC -> a -> XEventPtr -> IO Yavie.Keybind.Event +evpToEvent inbuf ic delWin ep = do + ev <- getEvent ep + case ev of + ExposeEvent {} -> do + getCurrentTime >>= writeIORef preTime . addUTCTime (-4) + return EvExpose + KeyEvent {} -> do + ( mstr, mks ) <- utf8LookupString ic ep + let ch = maybe ' ' head mstr + ks = fromMaybe xK_VoidSymbol mks + key = case ks of + _ | ks == xK_Return -> KEnter + | ks == xK_Escape -> KEsc + | ks == xK_Shift_L -> KUp + | ks == xK_Shift_R -> KUp + | otherwise -> KASCII ch + writeIORef inbuf $ maybe "" tail mstr + return $ EvKey key [ ] + ClientMessageEvent {} -> + if getClientMessageAtom ev == delWin + then exitFailure + else return $ EvKey KEsc [ ] + _ -> error "not yet implemented" + +getEventX11 :: XVars -> IO Yavie.Keybind.Event +getEventX11 ( dpy, _, _, _, _, _, ic, delWin, inbuf ) = + getKeyEvent inbuf dpy ic delWin + +getKeyEvent :: ( Convertible CInt a, Eq a ) => + IORef String -> Display -> XIC -> a -> IO Yavie.Keybind.Event +getKeyEvent inbuf dpy ic delWin = allocaXEvent $ \e -> do + ib <- readIORef inbuf + case ib of + c : _ -> do + modifyIORef inbuf tail + return $ EvKey ( KASCII c ) [ ] + _ -> do + nextNotFilteredEvent dpy e + evpToEvent inbuf ic delWin e + +getClientMessageAtom :: Convertible CInt a => Graphics.X11.Xlib.Extras.Event -> a +getClientMessageAtom = convert . head . ev_data + +preMon :: IORef [ a ] +preMon = unsafePerformIO $ newIORef [ ] +preTime :: IORef UTCTime +preTime = unsafePerformIO $ getCurrentTime >>= newIORef . addUTCTime (-1) + + + +drawDisplayX11 :: XVars -> IO ( Editor c ) -> IO () +drawDisplayX11 xvars@( dpy, win, _, _, _, _, _, _, _ ) datForDpy = do + dl <- datForDpy + let im = isBoxCursor dl + ( cx, cy ) = cursorPosOfDpy dl + lns = displayLines dl + ln = lns !! cy + bc = if im then "[" else "|" + ac = if im then "]" else "" + ch = if cx < 0 || cx >= length ln then ' ' else ln !! cx + nlns = take cy lns ++ + [ take cx ln ++ bc ++ [ ch ] ++ ac ++ drop ( cx + 1 ) ln ] ++ + drop ( cy + 1 ) lns + pmon <- readIORef preMon + tnow <- getCurrentTime + tpre <- readIORef preTime + let dt = diffUTCTime tnow tpre + when ( pmon /= nlns && dt > 0.05 ) $ do + writeIORef preMon nlns + writeIORef preTime tnow + clearWindow dpy win + zipWithM_ ( putStrX xvars color ( 0 :: Int ) ) [ ( 0 :: Int) .. ] nlns + +putStrX :: ( Integral a, Integral b ) => + XVars -> String -> a -> b -> String -> IO () +putStrX (dpy,_,visual,colormap,xftDraw,xftFont,_,_,_) col x y str = + withXftColorName dpy visual colormap col $ \clr -> + xftDrawString xftDraw clr xftFont ( 12 + 13 * x `div` 2 ) ( 12 + 15 * y ) str diff --git a/uuid_yavie b/uuid_yavie new file mode 100644 --- /dev/null +++ b/uuid_yavie @@ -0,0 +1,1 @@ +806dd5ac-5942-4c73-92cb-563d9e78f583 diff --git a/yavie.cabal b/yavie.cabal new file mode 100644 --- /dev/null +++ b/yavie.cabal @@ -0,0 +1,39 @@ +build-type: Simple +cabal-version: >= 1.2 + +name: yavie +version: 0.0.1 +stability: experimental +maintainer: Yoshikuni Jujo + +license: BSD3 +license-file: LICENSE + +category: Editor +synopsis: yet another visual editor +description: yet another visual editor + . + Customizable vi like editor. + You can customize by edit ~\/.yavie\/vty\/yavie-vty.hs. + It's very buggy now. + +data-files: uuid_yavie, + src/vty/yavie-vty.cabal, src/vty/yavie-vty.hs + src/x11/yavie-x11.cabal, src/x11/yavie-x11.hs + src/gtk/yavie-gtk.cabal, src/gtk/yavie-gtk.hs + +library + hs-source-dirs: src + exposed-modules: Yavie, Yavie.Keybind, Yavie.Keybind.Vi, Yavie.Editor + other-modules: Yavie.MainTools, + Yavie.EditorCore, Yavie.Tools + build-depends: base > 4 && < 5, + event-driven >= 0.0.2, filepath, monads-tf, regexpr + ghc-options: -Wall + +executable yavie + hs-source-dirs: src + main-is: Main.hs + other-modules: MainNoPaths + build-depends: base > 4 && < 5, directory, Cabal, process + ghc-options: -Wall