packages feed

yavie (empty) → 0.0.1

raw patch · 19 files changed

+2746/−0 lines, 19 filesdep +Cabaldep +basedep +directorysetup-changed

Dependencies added: Cabal, base, directory, event-driven, filepath, monads-tf, process, regexpr

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Main.hs view
@@ -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
+ src/MainNoPaths.hs view
@@ -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
+ src/Yavie.hs view
@@ -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 )
+ src/Yavie/Editor.hs view
@@ -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
+ src/Yavie/EditorCore.hs view
@@ -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
+ src/Yavie/Keybind.hs view
@@ -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 ) ()
+ src/Yavie/Keybind/Vi.hs view
@@ -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
+ src/Yavie/MainTools.hs view
@@ -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
+ src/Yavie/Tools.hs view
@@ -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
+ src/gtk/yavie-gtk.cabal view
@@ -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
+ src/gtk/yavie-gtk.hs view
@@ -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"
+ src/vty/yavie-vty.cabal view
@@ -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
+ src/vty/yavie-vty.hs view
@@ -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
+ src/x11/yavie-x11.cabal view
@@ -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
+ src/x11/yavie-x11.hs view
@@ -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
+ uuid_yavie view
@@ -0,0 +1,1 @@+806dd5ac-5942-4c73-92cb-563d9e78f583
+ yavie.cabal view
@@ -0,0 +1,39 @@+build-type:    Simple+cabal-version: >= 1.2++name:          yavie+version:       0.0.1+stability:     experimental+maintainer:    Yoshikuni Jujo <PAF01143@nifty.ne.jp>++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