1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{-# LANGUAGE GeneralizedNewtypeDeriving
, ScopedTypeVariables
#-}
module Editor where
import System.IO
import Buffer
import Control.Exception
import Control.Monad.State
import Control.Applicative
import Control.Arrow (first, second)
import Data.Char
import Data.List
-- Editor commands
data Command = View
| Edit
| Load String
| Line Int
| Next
| Prev
| Quit
| Help
| Noop
deriving (Eq, Show, Read)
commands :: [String]
commands = map show [View, Edit, Next, Prev, Quit]
-- Editor monad
newtype Editor b a = Editor (StateT (b,Int) IO a)
deriving (Functor, Monad, MonadIO, MonadState (b,Int))
runEditor :: Buffer b => Editor b a -> b -> IO a
runEditor (Editor e) b = evalStateT e (b,0)
getCurLine :: Editor b Int
getCurLine = gets snd
setCurLine :: Int -> Editor b ()
setCurLine = modify . second . const
onBuffer :: (b -> a) -> Editor b a
onBuffer f = gets (f . fst)
getBuffer :: Editor b b
getBuffer = onBuffer id
modBuffer :: (b -> b) -> Editor b ()
modBuffer = modify . first
io :: MonadIO m => IO a -> m a
io = liftIO
-- Utility functions
readMay :: Read a => String -> Maybe a
readMay s = case reads s of
[(r,_)] -> Just r
_ -> Nothing
-- Main editor loop
editor :: Buffer b => Editor b ()
editor = io (hSetBuffering stdout NoBuffering) >> loop
where loop = do prompt
cmd <- getCommand
when (cmd /= Quit) (doCommand cmd >> loop)
prompt :: Buffer b => Editor b ()
prompt = do
s <- onBuffer value
io $ putStr (show s ++ "> ")
getCommand :: Editor b Command
getCommand = io $ readCom <$> getLine
where
readCom "" = Noop
readCom inp@(c:cs) | isDigit c = maybe Noop Line (readMay inp)
| toUpper c == 'L' = Load (unwords $ words cs)
| c == '?' = Help
| otherwise = maybe Noop read $
find ((== toUpper c) . head) commands
doCommand :: Buffer b => Command -> Editor b ()
doCommand View = do
cur <- getCurLine
let ls = [(cur - 2) .. (cur + 2)]
ss <- mapM (\l -> onBuffer $ line l) ls
zipWithM_ (showL cur) ls ss
where
showL _ _ Nothing = return ()
showL l n (Just s) = io $ putStrLn (m ++ show n ++ ": " ++ s)
where m | n == l = "*"
| otherwise = " "
doCommand Edit = do
l <- getCurLine
io $ putStr $ "Replace line " ++ show l ++ ": "
new <- io getLine
modBuffer $ replaceLine l new
doCommand (Load filename) = do
mstr <- io $ handle (\(_ :: IOException) ->
putStrLn "File not found." >> return Nothing
) $ do
h <- openFile filename ReadMode
hSetEncoding h utf8
Just <$> hGetContents h
maybe (return ()) (modBuffer . const . fromString) mstr
doCommand (Line n) = modCurLine (const n) >> doCommand View
doCommand Next = modCurLine (+1) >> doCommand View
doCommand Prev = modCurLine (subtract 1) >> doCommand View
doCommand Quit = return () -- do nothing, main loop notices this and quits
doCommand Help = io . putStr . unlines $
[ "v --- view the current location in the document"
, "n --- move to the next line"
, "p --- move to the previous line"
, "l --- load a file into the editor"
, "e --- edit the current line"
, "q --- quit"
, "? --- show this list of commands"
]
doCommand Noop = return ()
inBuffer :: Buffer b => Int -> Editor b Bool
inBuffer n = do
nl <- onBuffer numLines
return (n >= 0 && n < nl)
modCurLine :: Buffer b => (Int -> Int) -> Editor b ()
modCurLine f = do
l <- getCurLine
nl <- onBuffer numLines
setCurLine . max 0 . min (nl - 1) $ f l
|