Hedi (empty) → 0.1
raw patch · 15 files changed
+1164/−0 lines, 15 filesdep +QuickCheckdep +basedep +mtlsetup-changed
Dependencies added: QuickCheck, base, mtl, parsec, pretty, process, readline, regex-posix
Files
- Buffer.hs +77/−0
- Editor.hs +216/−0
- Engine.hs +122/−0
- Eval.hs +83/−0
- Hedi.cabal +29/−0
- Helper.hs +78/−0
- LICENSE +23/−0
- Main.hs +62/−0
- Offset.hs +67/−0
- Operation.hs +78/−0
- Parser.hs +131/−0
- Setup.lhs +4/−0
- Test.hs +54/−0
- Undo.hs +71/−0
- command.help +69/−0
+ Buffer.hs view
@@ -0,0 +1,77 @@+-- | An Editor backend implementation, made of the instance of Engine of InsideAppend.+module Buffer (InsideAppend (..))+where++import Data.Maybe+import Engine+import Test.QuickCheck++-- |See the "Engine" class docs +data InsideAppend + -- | the cursor when its pointing to a real line (eg line function doesn't fail)+ = Inside {+ left :: [String], -- ^ lines before the cursor (reversed order)+ cursor ::String , -- ^ addressed line+ right :: [String] -- ^ lines after the cursor+ }+ -- | the cursor is pointing either to insert at the front of the file or + -- append at the end of the file.+ | Append + { + elems :: Either [String] [String] -- ^ Left lines is in append mode, Right is in insert at front mode.+ }+ deriving (Show , Eq)++instance Engine InsideAppend where+ listIn xs = Append (Right xs)+ prev (Append (Right _ )) = Nothing + prev (Append (Left [] )) = error "empty Append Left"+ prev (Append (Left (l:ls))) = Just $ Inside ls l [] + prev (Inside [] x ls) = Just $ Append (Right (x:ls)) + prev (Inside (l:ls) x rs) = Just $ Inside ls l (x:rs) + next (Append (Right [] )) = Nothing+ next (Append (Right (r:rs))) = Just $ Inside [] r rs + next (Append (Left [] )) = error "empty Append Left"+ next (Append (Left _ )) = Nothing+ next (Inside ls x [] ) = Just $ Append (Left (x:ls)) + next (Inside ls x (r:rs)) = Just $ Inside (x:ls) r rs + end w@ (Append (Left _)) = Just w+ end w = next w >>= end+ start w@ (Append (Right _)) = Just w+ start w = prev w >>= start + pos (Append (Left ls)) = End (length ls + 1)+ pos (Append (Right _)) = Begin+ pos (Inside ls _ _) = Line $ length ls + 1+ del (Append _) = Nothing+ del (Inside [] _ [] ) = Just $ Append (Right []) + del (Inside ls _ [] ) = Just $ Append (Left ls) + del (Inside ls _ (r:rs)) = Just $ Inside ls r rs+ deln n w | n == 0 = Just w+ | True = del w >>= deln (n-1)+ add xs (Append (Left _ )) = Nothing+ add xs (Append (Right rs)) = Just $ Append $ Right (xs ++ rs)+ add xs (Inside ls x rs) = Just $ Inside ls x (xs ++ rs) + ins xs w = prev w >>= add xs >>= next + jump n w = start w >>= rjump n + listOut w = start w >>= \(Append (Right rs)) -> return rs+ linen 0 _ = Just []+ linen _ (Append _) = Nothing+ linen n w@ (Inside _ x _ ) = next w >>= linen (n - 1) >>= Just . (x:)+ + tillend w = filter isInside (runner next w)++ fromstart w = reverse $ filter isInside (runner prev w)++ fwdcycle w = filter isInside $ runner next w ++ reverse (runner prev w) ++ [w]+ bwdcycle w = filter isInside $ runner prev w ++ reverse (runner next w) ++ [w] ++isInside :: InsideAppend -> Bool+isInside (Inside _ _ _) = True+isInside _ = False++runner :: Change InsideAppend -> InsideAppend -> [InsideAppend]+runner op w = maybe [] (\w -> (w : runner op w)) (op w)++prop_E1_IA = prop_E1 :: (W InsideAppend) -> String -> Bool +--prop_Empty_IA = prop_Empty :: +t = listIn ["paolo","va","in","bici"] :: InsideAppend
+ Editor.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE MultiParamTypeClasses,NoMonomorphismRestriction,FlexibleContexts,FlexibleInstances,UndecidableInstances #-}++-- | Main datas and types for the editor+module Editor+where++import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Error++import Undo+import Engine+++-- | Stato is parametrized on an Engine instance and hold the engine with the last regex entered , regex G and g are not implemented now+data Stato w = Stato {+ file :: w, -- ^ data holding the file + lastre :: String, -- ^ a regex+ filename :: Maybe String, -- ^ the file we are editing+ pending :: Maybe Command, -- ^ a sensible state for data lost+ lastsaved :: Maybe w+ } deriving (Show,Eq)++zeroState = Stato empty "" Nothing Nothing Nothing+-- | the core editor runs under the state monad with state (Stato w) .+-- Wrapped around a monad (IO mainly) to permit console input and output of commands with IO+-- and testing with State+type StatoE m w = UndoT (Stato w) m++liftStatoE :: Ctx m w => StatoE m w a -> Editor m w a+liftStatoE = lift ++-- | push a new file (data 'Engine' instance) in the core State, pushing the old state in the undo stack+hputfile :: Ctx m w => w -> Editor m w ()+hputfile x = get >>= \y -> liftStatoE $ hput y {file = x}++putfile x = get >>= \y -> put y {file = x}+putlastre x = get >>= \y -> put y {lastre = x} +setfilename x = get >>= \y -> put y {filename = x} +setpending x = get >>= \y -> put y {pending = x} +setlastsaved = get >>= \y -> put y {lastsaved = Just (file y)} +unsetlastsaved = get >>= \y -> put y {lastsaved = Nothing}+++ ++-- | placeholder for the two constraints+class (Engine w , SIO m, HCtx m (Stato w) ) => Ctx m w +instance (Engine w , SIO m, HCtx m (Stato w) ) => Ctx m w ++-- | the errors (monad failers) which can break the monad flow+data Err + = StopErr -- ^ issued on ctrl-d or q command (q not implemented)+ | ParserErr String -- ^ command line was not parsed to a CompleteCommand+ | RegexUnmatched -- ^ the regex doesn't match a line+ | EvalErr Err -- ^ something bad happened in the evaluation process+ | BackendErr -- ^ lines were addressed out of file (see 'Engine')+ | Ahi String -- ^ uncontrolled errors+ | FileReadErr String -- ^ io error trying to load a file+ | FileNameMissing -- ^ filename is not set+ | FileWriteErr String -- ^ io error trying to write the file+ | ExternalCommandErr String -- ^ io error executing an external program+ | PendingState Command -- ^ a sensible data discarding command has been entered+ | NoMoreUndo -- ^ reached the first state remembered+ | NoMoreRedo -- ^ reached the last state remembered+ | CommandHelpMissing -- ^ a help for a missing command was asked+ | CommandHelpParseErr String -- ^ error parsing the help for commands+ deriving Show ++instance Error Err where+ noMsg = Ahi "nomsg"+ strMsg = Ahi++-- | a layer for IO simulation, see "Main" for the real program one and "Test" for tests+class (Monad m) => SIO m where+ -- | accepts a prompt and should return Nothing on eof else a line of input+ inputSio :: String -> m (Maybe String) + outputSio :: String -> m () -- ^ output a normal string+ historySio :: String -> m () -- ^ put a line in the history (which is global)+ errorSIO :: String -> m () -- ^ output an error string+ readfileSio :: String -> ErrorT String m String -- ^ read a file+ writefileSio :: String -> String -> ErrorT String m () -- ^ write a file+ -- | runs an external command , first arg is the command+ -- the output is returned or an error is signalled in the errort monad+ externalSio :: String -> ErrorT String m String+ -- the path for the command help file+ commandhelpSIO :: m FilePath++liftSio :: Ctx m w => m a -> Editor m w a+liftSio = lift . lift ++-- | commands for the editor +data Command+ -- | get some text and add it after the addressed line+ = Append + -- | get some text and add it before the addressed line+ | Insert + -- | get some text and add it in place of some deleted lines+ | Change + -- | delete some lines+ | Delete + -- | print some lines+ | Print + -- | get some commands and execute them on each line matching a regex+ | SmallG String -- not implemented+ -- | interactively execute commands on each line matching a regex+ | BigG String -- not implemented+ -- | Change the addressed line+ | NoCommand+ -- | Load a file + | Edit String+ -- | Write the file+ | Write+ -- | Write a new file+ | WriteNew String + -- | Set filename+ | SetFilename String+ -- | Print filename+ | GetFilename+ -- | Load the output of an external command+ | EditExternal String+ -- | Revert the last change if ever+ | UndoChange+ -- | Restore via the last change+ | RedoChange+ -- | Asking help+ | HelpList+ -- | Spedific help+ | HelpTopic String+ deriving (Show,Eq)+++-- | represents a line position in the file+data Offset + -- | beyond last line, the append line+ = LastLine + -- | the nth line+ | Absolute Int + -- | the line addressed by the engine+ | Current + -- | the nth line before the addressed one+ | Prev Int + -- | the nth line aftor the addressed one+ | Next Int + -- | the next line (wrapping around) matching a regex+ | ReNext String + -- | the next line matching the last learned regex + | LastReNext+ -- | the previous line (wrapping around) matching a regex+ | RePrev String+ -- | the previous matching the last learned regex + | LastRePrev+ -- | the line marked previously with a char+ | MarkedAs Char deriving Show+-- | a couple of Offsets+data Range = Range Offset Offset deriving Show++-- | wrapper a round the two possible addressing for a command Offset and Range+data OffsetOrRange + = ORO Offset + | ORR Range + | ORN deriving Show++-- | a complete command is a Command coupled with a Range or an Offset+data CompleteCommand = CC Command OffsetOrRange deriving Show+++-- | main datatype for the program-- beyond the core state, a simulation layer 'SIO' can be read +-- and errors 'Err' can be thrown to kill the monad flow+type Editor m w = ErrorT Err (StatoE m w)+++-- | wrap a maybe action and throw a backend error on a Nothing +backend :: Ctx m w + => Maybe a -- ^ maybe action+ -> Editor m w a -- ^ monading +backend = maybe (throwError BackendErr) return++-- | execute an action on the file+through :: Ctx m w+ => (w -> Maybe a) -- ^ an action from an engine w to a maybe+ -> Editor m w a -- ^ the result from Just in the Editor monad+through f = gets file >>= backend . f+ ++-- | the inputSio action lifted to Editor+pinput :: Ctx m w => String -> Editor m w (Maybe String) +pinput = liftSio . inputSio++-- | the inputSio action lifted to Editor with empty prompt+input :: Ctx m w => Editor m w (Maybe String)+input = pinput ""++-- | the outputSio action lifted to Editor+output :: Ctx m w => String -> Editor m w () +output = liftSio . outputSio ++-- | the historySIO action lifted to Editor +history :: Ctx m w => String -> Editor m w ()+history = liftSio . historySio ++-- | the errorSIO action lifted to Editor+errorlog :: Ctx m w => String -> Editor m w ()+errorlog = liftSio . errorSIO ++-- | editor runner .+-- resolve the all monad from a core state to another+run :: Ctx m w + => Editor m w a -- ^ the action to run+ -> Stato w -- ^ the initial state + -> m (Stato w) -- ^ the final state wrapped in the monad choosen for the SIO++run editor w = flip execUndoT w $ runErrorT editor >>= \x -> + case x of Left err -> lift $ errorSIO (show err)+ Right _ -> return ()+
+ Engine.hs view
@@ -0,0 +1,122 @@+-- | Abstraction on a "zipped" list. Use these instances to have a list cursored on a position, also +-- called double linked list.+module Engine where++import Test.QuickCheck+import Control.Monad+import Data.Maybe+import Data.List++-- | represent an action, which can fail with Nothing , an index error+type Change a = a -> Maybe a++-- | Pos represent the position addressed in the engine+data Pos + -- | the engine addresses a real line + = Line { + nth :: Int -- ^ The index of the line starting from 1 + }+ -- | the engine addresses before first line , if ever present+ | Begin + -- | the engine addresses after last line+ | End {+ lns :: Int -- ^ The number of lines in the engine+ }+ deriving Show+-- | relative distance between two positions+distance (Line n) (Line m) = m - n +1+distance Begin (Line m) = m+distance (Line n) (End m) = m - n+distance Begin (End m) = m+distance _ _ = 0 ++-- | the class to implement for holding a list of elements with a cursor on them+class Eq a => Engine a where+ + -- | An empty engine+ empty :: a + empty = listIn []+ -- | An engine is isomorphic to a list+ listIn :: [String] -> a + -- | Extract the list from the engine+ listOut :: a -> Maybe [String] + -- | Extract n lines from the position addressed+ linen :: Int -> a -> Maybe [String] + -- | Extract the addressed line+ line :: a -> Maybe String + line w = head `fmap` linen 1 w+ -- | Possibly set the addressed line to the nth line+ jump :: Int -> Change a + -- | Insert some lines before the addressed line+ ins :: [String] -> Change a + -- | Insert some lines after the addressed line+ add :: [String] -> Change a + -- | Delete the addressed line , address the next one+ del :: Change a + -- | Delete n lines from the addressed position+ deln :: Int -> Change a + -- | Address an append position+ end :: Change a + -- | Address before the first line+ start :: Change a + -- | The number of the addressed line+ pos :: a -> Pos + -- | Address the next line+ next :: Change a + -- | Address the prev line+ prev :: Change a + -- | Jump back n lines + prevn :: Int -> Change a + prevn 0 w = Just w + prevn n w = prev w >>= prevn (n-1) + -- | Jump ahead n lines+ nextn :: Int -> Change a + nextn 0 w = Just w+ nextn n w = next w >>= nextn (n-1) + -- | Jump n lines relative to the addredded line+ rjump :: Int -> Change a + rjump n = iterateM n (if n > 0 then next else prev) where+ iterateM n f w | n > 0 = f w >>= iterateM (n - 1) f+ | True = Just w+ -- | Create all the engines from the addressed one to the last one + tillend :: a -> [a]+ -- | all the next engines from the addressed next to itself , wrapping around+ fwdcycle :: a -> [a]+ -- | Create all the engines from the start to the addressed one included+ fromstart :: a -> [a]+ -- | all the prev engines from the addressed prev to itself , wrapping around+ bwdcycle :: a -> [a]++-- | last element if present+last :: Engine w => Change w+last t = end t >>= prev+-- | first element if present+first :: Engine w => Change w+first t = start t >>= next++newtype W w = W w deriving Show+instance (Eq w,Engine w) => Arbitrary (W w) where+ arbitrary = do n <- choose (0,10)+ ws <- replicateM n $ replicateM 15 $ choose ('a','z')+ return $ W $ listIn ws+ coarbitrary = undefined +instance Arbitrary Char where+ arbitrary = choose ('a','z')+ coarbitrary = undefined+++++prop_E1 :: (Engine w) => W w -> String -> Bool+prop_E1 (W y) = \x -> (add [x] y >>= listOut) == Just (x:fromJust (listOut y))++propInOut f xs = Just $ listIn xs >>= f >>= listOut +prop_Empty (W y) = (y == empty) ==> prev y == Nothing && next y == Nothing+prop_toEnd (W y) = (y /= empty) ==> let Just ls = length `fmap` listOut y + in collect ls $ nextn (ls +1) y == end y && nextn ls y == (end y >>= prev)+prop_toEndAndBack (W y) = (y /= empty) ==> let Just ls = length `fmap` listOut y + in collect ls $ (end y >>= start) == Just y+prop_add (W y) xs = (add xs y >>= listOut) == Just xs +--prop_ins (W y) xs = (listIn xs >>= end >>= ins xs >>= listOut) == Just (head xs:head+--+-- data Prop w = forall p . (Engine w) => Prop w (\w -> \p -> Property)
+ Eval.hs view
@@ -0,0 +1,83 @@+-- | The logic of each of the available commands+module Eval where++import System.IO+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Error+import Editor+import Operation+import Offset+import Undo+import Helper+import Engine+++-- | every command is run with eval. See 'Editor.Command' datatype for docs+eval :: Ctx m w + => CompleteCommand -- ^ the command to match for execution+ -> Editor m w () -- ^ monading ..+++eval (CC Append (ORO o)) = inputMode >>= editOffset o . add+eval (CC Insert (ORO o)) = inputMode >>= editOffset o . ins+eval (CC Delete (ORO o)) = editOffset o del+eval (CC Delete (ORR r)) = editRange r deln+eval (CC Change (ORO o)) = do+ w <- jumpE o + (l,u) <- backend $ line w >>= \l -> del w >>= \u -> return (l,u)+ history l >> inputMode >>= backend . flip ins u >>= putfile++eval (CC Change (ORR r)) = do+ (n,w) <- rangeResolve r + u <- backend $ deln n w + inputMode >>= backend . flip ins u >>= putfile++eval (CC Print (ORO o)) = doOffset o output line+eval (CC Print (ORR r)) = doRange r (mapM_ output) linen+eval (CC NoCommand (ORO o)) = jumpE o >>= \w -> backend (line w) >>= output >> putfile w+eval (CC NoCommand ORN) = jumpE (Next 1) >>= \w -> backend (line w) >>= output >> putfile w+eval (CC NoCommand (ORR (Range o1 o2))) = jumpE o2 >>= putfile++eval (CC c@(Edit e) _) = evalSensible c $+ liftSio (runErrorT $ readfileSio e) >>=+ either (throwError . FileReadErr) (putfile . listIn . lines) >> + setfilename (Just e) >> setlastsaved +eval (CC Write _) = getname (throwError FileNameMissing) >>= write >> unsetlastsaved+ +eval (CC (WriteNew nname) _) = getname (return nname) >>= \name -> write nname >>+ setfilename (Just name) >> setlastsaved+eval (CC GetFilename _) = getname (throwError FileNameMissing ) >>= output+eval (CC c@(SetFilename s) _) = gets filename >>= flip (maybe id (const $ evalSensible c)) + (setfilename (Just s) >> unsetlastsaved)+eval (CC c@(EditExternal s) _) = evalSensible c $+ liftSio (runErrorT $ externalSio s) >>=+ either (throwError . ExternalCommandErr) (putfile . listIn . lines) >>+ unsetlastsaved+eval (CC UndoChange _) = liftStatoE undo >>= bool (return ()) (throwError NoMoreUndo) +eval (CC RedoChange _) = liftStatoE redo >>= bool (return ()) (throwError NoMoreRedo)+eval (CC HelpList _) = liftSio (runErrorT $ readfileSio "command.help") >>= + either (throwError . FileReadErr) (return . listOfCommands) >>= + either (throwError . CommandHelpParseErr) (maybe (throwError $ Ahi "Boh") output)+eval (CC (HelpTopic t) _) = liftSio (runErrorT $ readfileSio "command.help") >>= + either (throwError . FileReadErr) (return . helpCommand t) >>=+ either (throwError . CommandHelpParseErr) (maybe (throwError CommandHelpMissing) output)++bool x y b = if b then x else y++-- | throw a 'writerSio' error to Editor+writefail :: Ctx m w => Either String () -> Editor m w ()+writefail = either (throwError . FileWriteErr) return++-- | dump the engine content to a file via writefileSio+write :: Ctx m w + => String -- ^ filename+ -> Editor m w () -- ^ monading+write name = do + contents <- unlines `fmap` through listOut + (liftSio . runErrorT) (writefileSio name contents) >>= writefail+ setlastsaved+-- | get the filename defaulting to some other action to produce one+getname :: Ctx m w => Editor m w String -> Editor m w String+getname defaul = gets filename >>= maybe defaul return
+ Hedi.cabal view
@@ -0,0 +1,29 @@+Name: Hedi+Version: 0.1+Cabal-Version: >= 1.2+Description: Haskell line editor. Cloned from ed manual.+Category: Editor+Synopsis: Line oriented editor+License: BSD3+License-file: LICENSE+Author: Paolo Veronelli+Maintainer: paolo.veronelli@gmail.com+Build-type: Simple+data-files: command.help++Library+ Exposed-Modules: Engine,Editor,Operation,Eval,Parser,Helper,Offset,+ Main,Test,Buffer,Undo+ Build-Depends: base,mtl,parsec,regex-posix,readline,QuickCheck,+ process,pretty+ +Executable hedi+ Build-Depends: base,mtl,parsec,regex-posix,readline,QuickCheck,+ process,pretty+ Main-is: Main.hs+ other-modules: Engine,Editor,Operation,Eval,Parser,Helper,Offset,+ Test,Buffer,Undo+ extensions: NoMonomorphismRestriction,MultiParamTypeClasses,+ FlexibleContexts,FlexibleInstances,+ GeneralizedNewtypeDeriving+
+ Helper.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE ParallelListComp #-}+-- | Parse and pretty print the string of help of commands +module Helper where+import Control.Monad+import Text.ParserCombinators.Parsec.Prim+import Text.ParserCombinators.Parsec.Char+import Text.ParserCombinators.Parsec.Token+import Text.ParserCombinators.Parsec.Combinator+import Text.PrettyPrint (render,text,nest, (<>),(<+>),($$),sep)+import Data.List (transpose,find)+++-- |structure for the help of a command+data CommandHelp = CommandHelp {+ name :: String, -- ^ the command name+ synopsis :: String, -- ^ how to run it+ descriptions :: [String], -- ^ aspects+ errors :: [String], -- ^ errors explanations+ implementation :: String -- ^ implementation state+ }++instance Show CommandHelp where+ show (CommandHelp name synopsis descriptions errors implementation) = render $+ text ("Command: " ++ name ) $$ + nest 4 (+ text ("Synopsis: " ++ synopsis) $$+ (text ("Description: ") <> foldr1 ($$) (map text descriptions)) $$+ (text ("Errors: ") <> foldr1 ($$) (map text errors)) $$+ text ("Implementation: " ++ implementation)+ )+-- |parses a CommandHelp +parseACommandHelp :: CharParser () CommandHelp +parseACommandHelp = do+ name <- field 0 "command"+ synopsis <- field 1 "synopsis"+ descriptions <- many (try $ field 1 "description")+ errors <- many (try $ field 1 "error")+ implementation <- field 1 "implementation"+ return $ CommandHelp name synopsis descriptions errors implementation+ where+ field n name = replicateM n tab >> string name >> char ')' >> many space >> manyTill anyChar newline+ +-- |parses all commands help+parseCommandsHelp :: CharParser () [CommandHelp]+parseCommandsHelp = do+ rs <- many (try $ many emptyline >> parseACommandHelp) + manyTill anyChar eof+ return rs+ where+ emptyline = manyTill space newline++-- |run the parser against a string+run + :: String -- ^ The string to parse+ -> GenParser Char () a -- ^ the parser to use+ -> (a -> Maybe b) -- ^ a function to use on the result , if it succed + -> Either String (Maybe b) -- ^ the error showed if it fails or the result closed++run file p cl = either (Left . show) (Right . cl) (parse p "help parser" file) ++-- |create a nice table from lines of words+tabulate :: [[String]] -> String+tabulate = render . foldr1 ($$) . tabulate' . transpose where+ tabulate' (xs:[]) = map text xs+ tabulate' (xs:yss) = [text x $$ nest (maximum (map length xs) + 1) y| x <- xs | y <- tabulate' yss]++-- |parse a prettyprint of a list of command helps from a string+listOfCommands + :: String -- ^ the string with the help inside+ -> Either String (Maybe String) -- ^ a parse error or Just a prettyprint of a list of command helps+listOfCommands file = run file parseCommandsHelp (Just . tabulate . map (\c -> [synopsis c , name c]))++-- |parse a prettyprint of a list of command helps from a string+helpCommand+ :: String -- ^ the command name+ -> String -- ^ the string with the help inside+ -> Either String (Maybe String) -- ^ a parse error or (Just the command help or Nothing if the command is missing)+helpCommand s file = run file parseCommandsHelp (\xs -> find ((==s).name) xs >>= return . show)
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2002, Paolo Veronelli. 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.+ +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 EVENT SHALL THE COPYRIGHT HOLDERS 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.
+ Main.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances #-}+module Main where++import System.Console.Readline+import Control.Exception as Exc+import System.Process+import System.Exit+import System.IO+import Control.Monad.Error+import Text.PrettyPrint (render,text,nest, (<>),(<+>),($$),sep)+import Buffer+import Editor+import Operation+import Eval+import Parser+import Engine+import Undo +import Paths_Hedi++-- | a SIO data made right for running the editor +instance SIO IO where+ inputSio = readline+ outputSio = putStrLn+ historySio = addHistory+ errorSIO = putStrLn+ readfileSio = handleWith show . strictReadFile+ writefileSio x y = handleWith show (writeFile x y) + externalSio = externalCommand + commandhelpSIO = getDataFileName "command.help"++handleWith h f = ErrorT $ Exc.catch (Right `fmap` f) (return . Left . h)+strictReadFile x = readFile x >>= \x -> Exc.evaluate (length x) >> return x++-- |launches an external program , catching output and errors, return on exit+externalCommand :: String -> ErrorT String IO String+externalCommand s = ErrorT $ do+ (_,output,error,h) <- runInteractiveCommand s+ status <- waitForProcess h+ output <- hGetContents output+ error <- hGetContents error+ return $ case status of + ExitSuccess -> Right output+ ExitFailure _ -> Left error++-- | the greetings+greetings :: IO ()+greetings = putStrLn . render $+ text "Hedi command line editor. " <> (+ text "Version 0.1" $$+ text "Released under BSD licence." $$+ text "Copyright 2008 Paolo Veronelli" $$+ text "Homepage http://code.haskell.org/Hedi")+ $$ text " "+ $$ text "Type \"he\" for help or \"he command\" for help on command"+ $$ text "Type \"CTRL-D\" to quit without saving"+ +main :: IO ()+main = do+ run (liftIO greetings >> commandLoop parse eval) + (Stato empty "" Nothing Nothing Nothing) :: IO (Stato InsideAppend)+ return ()+
+ Offset.hs view
@@ -0,0 +1,67 @@+-- | Operations involving Offset and Range through Engine interface+module Offset where+import Text.Regex.Posix +import Data.List (find)+import Data.Maybe (fromJust)+import Control.Monad.State+import Editor+import Engine++-- | move the cursor in the engine+jumpE :: Ctx m w + => Offset -- ^ the new position for the cursor+ -> Editor m w w -- ^ the modified engine under the Editor++jumpE Current = through Just +jumpE LastLine = through Engine.last +jumpE (Next n) = through $ nextn n +jumpE (Prev n) = through $ prevn n +jumpE (Absolute n) = through $ jump n +jumpE (ReNext s) = putlastre s >> (through . finder fwdcycle) s+jumpE LastReNext = gets lastre >>= through . finder fwdcycle +jumpE (RePrev s) = putlastre s >> (through . finder bwdcycle) s+jumpE LastRePrev = gets lastre >>= through . finder bwdcycle ++ +finder f s = find ((=~ s) . fromJust . line) . f++-- | From a range to the tuple (nelements,starting range element)+rangeResolve :: Ctx m w + => Range -- ^ the range to focus+ -> Editor m w (Int, w) -- ^ the tuple (nelements,engine placed+ -- at first offset of range)+rangeResolve (Range o1 o2) = do + w1 <- jumpE o1 + w2 <- jumpE o2 + return (distance (pos w1) (pos w2) , w1)++-- | a complete backend + Editor action on an Offset+doOffset :: Ctx m w + => Offset -- ^ Offset for the action+ -> (a -> Editor m w b) -- ^ the final action+ -> ( w -> Maybe a) -- ^ the backend ation+ -> Editor m w b -- ^ ..+doOffset o ef mf = jumpE o >>= backend . mf >>= ef++-- | a backend action ending in a save state for the file+editOffset :: Ctx m w + => Offset -- ^ Offset for the backend action+ -> ( w -> Maybe w) -- ^ the backend ation+ -> Editor m w () -- ^ modified monad+editOffset o = doOffset o hputfile ++-- | a complete backend + Editor action on a Range+doRange :: Ctx m w+ => Range -- ^ the addressed range+ -> (a -> Editor m w b) -- ^ the closing Editor action+ -> (Int -> w -> Maybe a) -- ^ the backend action + -> Editor m w b -- ^ ... +doRange r ef mf = rangeResolve r >>= backend . uncurry mf >>= ef++editRange :: Ctx m w+ => Range -- ^ the addressed range+ -> (Int -> w -> Maybe w) -- ^ the backend action + -> Editor m w () -- ^ modified monad+editRange r = doRange r hputfile++
+ Operation.hs view
@@ -0,0 +1,78 @@+-- | Functions for read-eval-do managing+module Operation where++import Control.Monad.State+import Control.Monad.Error++import Editor+import Engine+import Offset++-- | a real check for file modification+modified :: Ctx m w => Editor m w Bool+modified = do+ lastw <- gets lastsaved+ now <- gets file+ return $ maybe True (== now) lastw++resetpending :: Ctx m w => Editor m w ()+resetpending = setpending Nothing++-- | a wrapper for commands evaluation which can discard changes+evalSensible :: Ctx m w => Command -> Editor m w () -> Editor m w ()+evalSensible c action = do+ mod <- modified+ if mod then + let onunpending = setpending (Just c) >> errorlog (show $ PendingState c)+ onpending x = if x == c then action >> resetpending+ else onunpending+ in gets pending >>= maybe onunpending onpending+ else action >> resetpending ++-- | a wrapper for commands evaluation which cannot discard changes+checkPendings :: Ctx m w => Editor m w () -> Editor m w ()+checkPendings action = do+ pends <- gets pending+ action + newpends <- gets pending + when (newpends == pends) resetpending+++-- | a step in main mode for the editor+commandMode :: Ctx m w + => (String -> Either String CompleteCommand) -- ^ the parser for the command on the line+ -> (CompleteCommand -> Editor m w ()) -- ^ the evaluator for the parsed command+ -> Editor m w () -- ^ updated beast+commandMode parse eval = let + parseval line = either (throwError . ParserErr ) + ((history line >>). checkPendings . eval) + (parse line)+ prompt = do + p <- gets $ pos . file+ pinput $ case p of + Begin -> "0 > "+ Line p -> show p ++ " > "+ End _ -> "$ > "+ in prompt >>= maybe (throwError StopErr) parseval++-- | looping in main mode with error log on output+commandLoop :: Ctx m w + => (String -> Either String CompleteCommand) -- ^ the parser for the command on the line+ -> (CompleteCommand -> Editor m w ()) -- ^ the evaluator for the parsed command+ -> Editor m w () -- ^ updated beast++commandLoop parse eval = let + reaction StopErr = errorlog "End" >> return False+ reaction (Ahi x) = errorlog ("Unhandled exception: " ++ x) >> return False+ reaction BackendErr = errorlog "Buffer index error" >> return True+ reaction (ParserErr s) = errorlog ("Parser error: " ++ s) >> return True+ reaction err = errorlog ("Evaluation error: " ++ show err) >> return True+ in do run <- catchError (commandMode parse eval >> return True) reaction + if run then commandLoop parse eval else return ()++-- | the secondary mode for the editor where lines are inserted as input. It returns the lines.Use CTRL-D to exit +inputMode :: Ctx m w => Editor m w [String] +inputMode = input >>= maybe (aline "") aline+ where aline jl = case jl of+ "." -> return []+ otherwise -> inputMode >>= return . (jl:)
+ Parser.hs view
@@ -0,0 +1,131 @@+module Parser +where++import Text.ParserCombinators.Parsec.Token +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language+import Text.ParserCombinators.Parsec.Error++import Editor+import Offset+++-- | shortcut for a parser of chars with no state+type ParseE = GenParser Char ()++-- | parse an integer number+numero :: ParseE Integer+numero = natural haskell++parseFilename = manyTill anyChar ((many1 space >> return ()) <|> eof)+parseExternalCommand = char '!' >> manyTill anyChar eof+parseCommandName = parseFilename++-- | parse an Offset+parseOffset :: ParseE Offset+parseOffset = let+ lastline = char '$' >> return LastLine+ absolute = numero >>= return . Absolute . fromInteger+ current = char '.' >> return Current+ previous1 = char '-' >> numero >>= return . Prev. fromInteger + previous2 = many1 (char '-') >>= return . Prev . length + next1 = (space <|> char '+') >> numero >>= return . Next . fromInteger+ next2 = many1 (char '+') >>= return . Next . length+ are c = char c >> manyTill anyChar ((char c >> return ()) <|> eof)+ renext = are '/' >>= return . ReNext+ lastrenext = string "//" >> return LastReNext+ reprev = are '?' >>= return . RePrev+ lastreprev = string "??" >> return LastRePrev+ markedas = string "'" >> lower >>= return . MarkedAs+ in choice (map try [lastline,absolute,current,previous1,previous2,next1,next2,+ lastrenext,renext,lastreprev,reprev,markedas]) ++-- | parse a Range+parseRange :: ParseE Range +parseRange = let + couple = do + l <- parseOffset+ char ','+ r <- parseOffset+ return $ Range l r+ coma = char ',' >> return (Range (Absolute 1) LastLine)+ semicoma = char ';' >> return (Range Current LastLine)+ in choice (map try [coma,semicoma,couple])++-- | defaults Offset or Range for the commands+defaultOR :: Command -> OffsetOrRange+defaultOR Append = ORO Current+defaultOR Insert = ORO Current+defaultOR Change = ORO Current+defaultOR Print = ORO Current+defaultOR (SmallG _) = ORR (Range (Absolute 1) (Current))+defaultOR (BigG _) = ORR (Range (Absolute 1) (Current))+defaultOR Delete = ORO Current+defaultOR NoCommand = ORN+defaultOR (Edit _) = ORN+defaultOR Write = ORN+defaultOR (WriteNew _) = ORN+defaultOR (SetFilename _) = ORN+defaultOR GetFilename = ORN+defaultOR (EditExternal s) = ORN+defaultOR UndoChange = ORN+defaultOR RedoChange = ORN++-- | forces a failure for a command if a Range was parsed+acceptOffsetOnly :: Command -> OffsetOrRange -> ParseE ()+acceptOffsetOnly c (ORR _) = pzero <?> ("only offsets for function " ++ show c ++ ".")+acceptOffsetOnly _ _ = return ()++-- | parse an OffsetOrRange+parseOffsetOrRange :: ParseE OffsetOrRange+parseOffsetOrRange + = try (parseRange >>= return . ORR) + <|> try (parseOffset >>= return .ORO) + <|> return ORN++-- | helper for skipping a filter+rconst :: Command -> ParseE (OffsetOrRange -> ParseE Command)+rconst = return . const . return++-- | parse a function from OffsetOrRange to a parse Command+parseCommand :: ParseE (OffsetOrRange -> ParseE Command)+parseCommand = let + append = char 'a' >> eof >> return (\r -> acceptOffsetOnly Append r >> return Append)+ insert = char 'i' >> eof >> return (\r -> acceptOffsetOnly Insert r >> return Insert)+ change = char 'c' >> eof >> rconst Change+ delete = char 'd' >> eof >> rconst Delete+ print = char 'p' >> eof >> rconst Print+ smallg = char 'g' >> char '/' >> many1 (noneOf "/") + >>= \p -> char '/' >> eof >> rconst (SmallG p)+ bigg = char 'G' >> char '/' >> many1 (noneOf "/") + >>= \p -> char '/' >> eof >> rconst (BigG p)+ nocomm = eof >> rconst NoCommand + extedit = char 'e' >> many1 space >> parseExternalCommand >>= rconst . EditExternal+ edit = char 'e' >> many1 space >> parseFilename >>= rconst . Edit+ writen = char 'w' >> many1 space >> parseFilename >>= rconst . WriteNew+ write = char 'w' >> rconst Write + setfn = char 'f' >> many1 space >> parseFilename >>= rconst . SetFilename+ getfn = char 'f' >> rconst GetFilename+ undo = char 'u' >> rconst UndoChange+ redo = char 'R' >> rconst RedoChange+ shelp = string "he" >> many1 space >> parseCommandName >>= rconst . HelpTopic+ help = string "he" >> rconst HelpList+ in choice (map try [append,insert,change,delete,+ print,smallg,bigg,extedit,edit+ ,writen,write,setfn,getfn,undo,+ shelp,help,redo]) <|> nocomm++-- | parse a CompleteCommand made of an OffsetOrRange and a Command+parser :: ParseE CompleteCommand+parser = do + r <- parseOffsetOrRange + c <- parseCommand >>= ($ r)+ return $ CC c $ case r of + ORN -> defaultOR c+ _ -> r++-- | the parser from a String to either a String representing an error or a CompleteCommand+parse :: String -> Either String CompleteCommand +parse s = either (Left . show) Right $ Text.ParserCombinators.Parsec.parse parser "Command Parser" s+ +
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ Test.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE MultiParamTypeClasses,GeneralizedNewtypeDeriving,TypeSynonymInstances,UndecidableInstances,FlexibleContexts,FlexibleInstances #-}+-- | some framework to test Editor m w functions, intercepting the console part of the IO+module Test where+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Error++import Control.Monad.Writer++import Buffer+import Editor+import Eval+import Operation+import Parser+import Undo++type Line = String++[ebuffer,eend] = ["Buffer index error","End"]++data Console = Console {+ cinput :: [Line],+ coutput :: [Line],+ cerror :: [Line],+ chistory:: [Line]+ } deriving Show+type CState = State Console++outputT :: String -> CState () +outputT x = modify (\y -> y{coutput = x:coutput y})+errorT :: String -> CState () +errorT x = modify (\y -> y{cerror = x:cerror y})+historyT x = modify (\y -> y{chistory = x:chistory y})+++inputT :: String -> CState (Maybe String)+inputT _ = get >>= \y -> let t = cinput y in if null t then return Nothing else put y{cinput = tail t} >> return (Just (head t))+++instance SIO CState where+ inputSio = inputT+ outputSio = outputT+ errorSIO = errorT+ historySio = historyT+ readfileSio = undefined+ writefileSio = undefined+ externalSio = undefined+ commandhelpSIO = undefined++runT is os es hs = execState (run (commandLoop parse eval) zeroState :: CState (Stato InsideAppend)) (Console is os es hs)+test is mos mes mhs = let Console _ os es hs = runT is [] [] []+ in maybe True (== os) mos && maybe True (== es) mes && maybe True (== hs) mhs++loadFile x = readFile x >>= return . ("a" :) . lines
+ Undo.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE NoMonomorphismRestriction,MultiParamTypeClasses,FlexibleContexts,+ FlexibleInstances,GeneralizedNewtypeDeriving,UndecidableInstances #-}+-- | This code has been taken from <http://haskell.org> +-- A Monad transformer UndoT on a state supporting undo , redo and hput to push the last state on history.+-- Redo stack is blanked on hput+module Undo where++import Control.Monad.State++-- | State stacks wrapping states in time+data History s = History { + current :: s, -- ^ last state putted+ undos :: [s], -- ^ the history of putted states (reversed) without the redos+ redos :: [s] -- ^ history of the undo+ } deriving Show++-- | a state monad transformer with the state history+type HStateT s m = StateT (History s) m++-- | facility to write signatures context+class (Monad m, MonadState (History s) (HStateT s m)) => HCtx m s +instance (Monad m, MonadState (History s) (HStateT s m)) => HCtx m s+-- | a wrapper around HStateT to derive his classes and add an instance+newtype Monad m => UndoT s m a = UndoT (HStateT s m a) deriving (Functor, Monad, MonadTrans, MonadIO)++-- | the MonadState instance for the wrapper+instance (Monad m) => MonadState s (UndoT s m) where+ get = UndoT $ gets current+ put x = UndoT $ get >>= \(History _ us rs) -> put $ History x us rs++-- | tries to get back one step the state+undo :: HCtx m s + => UndoT s m Bool -- ^ False if the undo stack was empty+undo = UndoT $ do + History c us rs <- get+ if null us then return False + else put (History (head us) (tail us) (c : rs)) >> return True+-- | tries to get back the undo operation+redo :: HCtx m s+ => UndoT s m Bool -- ^ False if the redo stack was empty+redo = UndoT $ do+ History c us rs <- get+ if null rs then return False + else put (History (head rs) (c : us) (tail rs)) >> return True++-- | push the old state in the undo stack and set the new state (alternative to put)+hput :: HCtx m s + => s -- ^ the new state to put+ -> UndoT s m () -- ^ monading+hput x = UndoT $ do + History c undos redos <- get+ put (History x (c:undos) [])++-- | an History of one state+blank :: s -> History s+blank s = History s [] []++-- | run the UndoT monad transformer spitting out the computation result in the inner monad+evalUndoT :: (Monad m) + => UndoT s m a -- ^ a UndoT action+ -> s -- ^ the initial state+ -> m a -- ^ the result+evalUndoT (UndoT x) s = evalStateT x (blank s)++-- | run the UndoT monad transformer spitting out the final state in the inner monad+execUndoT :: (Monad m) + => UndoT s m a -- ^ a UndoT action+ -> s -- ^ the initial state+ -> m s -- ^ the final state+execUndoT (UndoT x) s = liftM current $ execStateT x (blank s)+
+ command.help view
@@ -0,0 +1,69 @@+command) append+ synopsis) [offset]a+ description) add some lines of text after offset line+ description) default offset is current line+ error) a buffer error when offset is unreachable+ implementation) implemented+command) insert+ synopsis) [offset]i+ description) insert some lines of text before offset line+ description) default offset is current line+ error) a buffer error when offset is unreachable+ error) a buffer error when trying to insert before line 0+ implementation) implemented+command) delete+ synopsis) [offset|range]d+ description) delete one line or a range of them+ description) default offset is current line+ error) a buffer error when trying to delete out of file+ implementation) implemented++command) change+ synopsis) [offset|range]c+ description) delete one line or a range and append there+ description) default is current line+ error) a buffer error when trying to delete out of file+ implementation) implemented++command) edit+ synopsis) e filename+ description) loads a new file in the buffer+ error) file not found+ implementation) implemented++command) edit shell+ synopsis) e !shell+ description) load the output of a command in the buffer+ error) errors from systems , coming from the shell command execution environment+ implementation) implemented+ +command) write+ synopsis) w [filename]+ description) write the buffer to a file+ description) if argument is missing, write to the filename set+ error) a -filename not set- if buffer has no filename + implementation) implemented++command) filename+ synopsis) f [filename]+ description) set or get the filename buffer+ error)+ implementation) implemented+command) undo+ synopsis) u+ description) bring the buffer back to before last modification+ error) a -no more states- if the first state remembered is hit+ implementation) implemented+command) redo+ synopsis) R+ description) put the buffer ahead one state, if no modifications happened after last undo+ error) a -no more states- if redo states stack is empty+ implementation) implemented++++++++