Fixed `Editor.hs` file from CIS 194: Homework 7 (Spring '13)

Editor.hs

{-# 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, Applicative, 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