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