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