[added src anchored html colourised paolo.veronelli@gmail.com**20080209175443] { addfile ./docs/src/Buffer.html hunk ./docs/src/Buffer.html 1 + + +
+ +-- | 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 ++ addfile ./docs/src/Editor.html hunk ./docs/src/Editor.html 1 + + + + +
{-# 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) + +-- | 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 () + ++ addfile ./docs/src/Engine.html hunk ./docs/src/Engine.html 1 + + + + +
-- | 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) ++ addfile ./docs/src/Eval.html hunk ./docs/src/Eval.html 1 + + + + +
-- | 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 ++ addfile ./docs/src/Helper.html hunk ./docs/src/Helper.html 1 + + + + +
{-# 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) ++ addfile ./docs/src/Main.html hunk ./docs/src/Main.html 1 + + + + +
{-# 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 () + ++ addfile ./docs/src/Offset.html hunk ./docs/src/Offset.html 1 + + + + +
-- | 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 + + ++ addfile ./docs/src/Operation.html hunk ./docs/src/Operation.html 1 + + + + +
-- | 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 (return []) aline + where aline jl = inputMode >>= return . (jl:) ++ addfile ./docs/src/Parser.html hunk ./docs/src/Parser.html 1 + + + + +
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 + + ++ addfile ./docs/src/Test.html hunk ./docs/src/Test.html 1 + + + + +
{-# LANGUAGE MultiParamTypeClasses,TypeSynonymInstances,UndecidableInstances,FlexibleContexts,FlexibleInstances #-} +-- | some framework to test Editor m w functions, providing a non IO-stacked monad m +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 Parser +import Engine +import Undo +-- ErrorT String m String + +data Console = Console {cinput::[Maybe String],coutput :: [String]} + +type WESC = WriterT [String] (State Console) +instance SIO WESC where + inputSio = predefinedInput + outputSio = normalOutput + historySio = ignoreSio + errorSIO = logerrors + readfileSio = readfile + writefileSio = writefile + externalSio = \_ -> (ErrorT . return) (Right "") + commandhelpSIO = return "command.txt" + +ignoreSio = const $ return () :: a -> WESC () +predefinedInput = const $ get >>= \(Console i o) -> put (Console (tail i) o) >> return (head i) +normalOutput s = get >>= \(Console i o) -> put $ Console i (s:o) +logerrors s = tell [s] +readfile :: String -> ErrorT String WESC String +readfile _ = return " " +writefile _ _ = return () + + +-- | Testing a console function leaving out file IO +commandTest + :: Test -- ^ test to be executed + -> Either [String] Bool -- ^ Left on errors, Right with the test +commandTest (Test cline input textIn textOut) = let + instate = Stato (listIn textIn) "" Nothing Nothing Nothing + checkstate = Console (map Just input ++ [Nothing]) [] + check = either (throwError . ParserErr) eval (parse cline) :: Editor WESC InsideAppend () + done = run check instate + (result,errors) = evalState (runWriterT done) checkstate + in if null errors then Right ((listOut.file) result == Just textOut) else Left errors + +-- | valid data for testing +data Test = Test { + commandT ::String, -- ^ The command to test + inputT ::[String], -- ^ What will be eventually read as input + startT ::[String], -- ^ The file as a list of line + endT ::[String] -- ^ The modified file + } + +[prima,seconda,terza] = lines "prima\nseconda\nterza" + +test = Test "$a" [prima] [seconda] [seconda,prima] + ++ addfile ./docs/src/Undo.html hunk ./docs/src/Undo.html 1 + + + + +
{-# 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) + ++ addfile ./docs/src/hscolour.css hunk ./docs/src/hscolour.css 1 + +.keyglyph, .layout {color: red;} +.keyword {color: blue;} +.comment, .comment a {color: green;} +.str, .chr {color: teal;} +.keyword,.conid, .varid, .conop, .varop, .num, .cpp, .sel, .definition {} }