Commit 738fcde7 authored by bbr's avatar bbr
Browse files

robustness and appendfile

- test exit code to see if gui handle is still valid
- appendfile adds string to existent file if known,
- otherwise just as a new file
parent a3d388f8
......@@ -142,9 +142,11 @@ prim_readFile = ioFunc1 "prim_readFile" (extVal `dot` addReadFile)
prim_writeFile :: String -> String -> Step (IO ())
prim_writeFile = ioFunc2 "prim_writeFile" addWrittenFile
prim_appendFile _ = Prelude.error "" --return ()
prim_appendFile :: String -> String -> Step (IO ())
prim_appendFile = ioFunc2 "prim_appendFile" addAppendedFile
catchFail = Prelude.error ""
catchFail :: Step (IO a) -> Step (IO a) -> Step (IO a)
catchFail = Prelude.error "catchFail not yet supported"
prim_show :: StrictCurry a => a -> Step String
prim_show = trace1 "prim_show" Prelude.show
......
......@@ -12,25 +12,23 @@ hello= listToDeq
\(____/()(____)()(_____)() Oracles\n\
\---------------------------------\n\n\n"
widget st lref ref cb rb wb act = Col [LeftAlign] [
Row [] [PlainButton [Text "Console",WRef cb,Active (act==Console),
Handler DefaultEvent (showConsole st)],
PlainButton [Text "Files read",Active (act==ReadFiles),WRef rb,
Handler DefaultEvent (showReadFile st 0)],
PlainButton [Text "Files written",Active (act==WrittenFiles),WRef wb,
Handler DefaultEvent (showWrittenFile st 0)]],
Row [] [ListBox [FillY,Width 0,WRef lref,
Handler DefaultEvent (selectFile st)],
TextEditScroll [Text $ deqToList hello,WRef ref,TclOption ""]]
widget st lref ref cb fb act = Col [LeftAlign] [
row [PlainButton [Text "Console",WRef cb,Active (act==Console),
Handler DefaultEvent (showConsole st)],
PlainButton [Text "Files",Active (act==Files),WRef fb,
Handler DefaultEvent (showFile True st 0)]],
row [ListBox [FillY,Width 0,WRef lref,
Handler DefaultEvent (selectFile st)],
TextEditScroll [Text $ deqToList hello,WRef ref]]
]
main = do
let cref,rb,wb,lref,cb free
let cref,fb,lref,cb free
stdinUnbuffered
state <- newIORef (emptyState cref rb wb lref cb)
state <- newIORef (emptyState cref fb lref cb)
runInitHandlesControlledGUI "B.I.O.tope -- the debugging environment"
(widget state lref cref cb rb wb Console,[readMessages state])
(widget state lref cref cb fb Console,[readMessages state])
(readMessages state stdin) [stdin]
......@@ -38,29 +36,27 @@ main = do
-- the state and how to reset it
---------------------------------------------------------------------------
data ActiveWidget = Console | ReadFiles | WrittenFiles
data ActiveWidget = Console | Files
type Files = [(String,String)]
type State = {readFiles, writtenFiles :: Files,
type State = {files :: Files,
console :: Queue Char,active :: ActiveWidget,
listWidget,textWidget,
consoleButton,readButton,writtenButton :: WidgetRef}
consoleButton,fileButton :: WidgetRef}
emptyState r1 r2 r3 r4 r5 =
{readFiles=[],writtenFiles=[],console=hello, active=Console,
textWidget=r1,readButton=r2,writtenButton=r3,
listWidget=r4,consoleButton=r5}
emptyState r1 r2 r3 r4 =
{files=[],console=hello, active=Console,
textWidget=r1,fileButton=r2,
listWidget=r3,consoleButton=r4}
reset :: GuiPort -> IORef State -> IO [ReconfigureItem]
reset gp ref = do
st <- readIORef ref
writeIORef ref {readFiles:=[],writtenFiles:=[],console:=hello,
active:=Console|st}
writeIORef ref {files:=[],console:=hello,active:=Console|st}
setValue (st->textWidget) (deqToList hello) gp
return [WidgetConf (st->listWidget) (List []),
acti False (st->readButton),
acti False (st->writtenButton),
acti False (st->fileButton),
acti False (st->consoleButton)]
......@@ -81,17 +77,21 @@ addConsole gp ref c = do
WidgetConf (st->listWidget) (List [])]
addReadFile :: GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem]
addReadFile gp ref f = do
addFile :: Bool -> GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem]
addFile append gp ref f@(fn,cont) = do
st <- readIORef ref
writeIORef ref {readFiles:=st->readFiles++[f] | st}
showReadFile ref (length (st->readFiles)) gp
addWrittenFile :: GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem]
addWrittenFile gp ref f = do
st <- readIORef ref
writeIORef ref {writtenFiles:=st->writtenFiles ++ [f] | st}
showWrittenFile ref (length (st->writtenFiles)) gp
let fs = st->files
case break ((==tail fn) . tail . fst) fs of
(_,[]) -> do
writeIORef ref {files:=st->files++[f] | st}
showFile True ref (length (st->files)) gp
(xs,(y,yc):ys) -> if append
then do
writeIORef ref {files:=xs++ys++[(fn,yc++cont)] | st}
showFile True ref (length (st->files) - 1) gp
else do
writeIORef ref {files:=xs++ys++[f] | st}
showFile True ref (length (st->files) - 1) gp
---------------------------------------------------------------------------
-- showing content in text/list widget
......@@ -101,25 +101,18 @@ selectFile :: IORef State -> GuiPort -> IO [ReconfigureItem]
selectFile ref gp = do
st <- readIORef ref
i <- getValue (st->listWidget) gp
case st->active of
ReadFiles -> showReadFile ref (readInt i) gp
WrittenFiles -> showWrittenFile ref (readInt i) gp
showFile False ref (readInt i) gp
showReadFile :: IORef State -> Int -> GuiPort -> IO [ReconfigureItem]
showReadFile ref i gp = do
showFile :: Bool -> IORef State -> Int -> GuiPort -> IO [ReconfigureItem]
showFile listchanged ref i gp = do
st <- readIORef ref
setValue (st->textWidget) (snd (st->readFiles !! i)) gp
writeIORef ref {active:=ReadFiles|st}
return [activate st,acti False (st->readButton),
WidgetConf (st->listWidget) (List (map fst (st->readFiles)))]
showWrittenFile :: IORef State -> Int -> GuiPort -> IO [ReconfigureItem]
showWrittenFile ref i gp = do
st <- readIORef ref
setValue (st->textWidget) (snd (st->writtenFiles !! i)) gp
writeIORef ref {active:=WrittenFiles|st}
return [activate st,acti False (st->writtenButton),
WidgetConf (st->listWidget) (List (map fst (st->writtenFiles)))]
setValue (st->textWidget) (snd (st->files !! i)) gp
writeIORef ref {active:=Files|st}
return (activate st:acti False (st->fileButton):
if listchanged
then map (WidgetConf (st->listWidget))
[List (map fst (st->files)),Text (show i)]
else [])
showConsole :: IORef State -> GuiPort -> IO [ReconfigureItem]
showConsole ref gp = do
......@@ -131,9 +124,8 @@ showConsole ref gp = do
activate :: State -> ReconfigureItem
activate st = acti True (case st -> active of
ReadFiles -> (st->readButton)
WrittenFiles -> (st->writtenButton)
Console -> (st->consoleButton))
Files -> (st->fileButton)
Console -> (st->consoleButton))
acti b ref = WidgetConf ref (Active b)
......@@ -152,11 +144,15 @@ readMessages ref h gp = do
'r' -> do
l <- hGetLine h
cont <- getFileCont h
addReadFile gp ref (l,cont)
addFile False gp ref ("R: "++l,cont)
'w' -> do
l <- hGetLine h
cont <- getFileCont h
addWrittenFile gp ref (l,cont)
addFile False gp ref ("W: "++l,cont)
'a' -> do
l <- hGetLine h
cont <- getFileCont h
addFile True gp ref ("W: "++l,cont)
'q' -> exitGUI gp >> return []
'!' -> reset gp ref
_ -> return []
......
......@@ -6,7 +6,9 @@ module StrictSteps (
ConsTerm, consTerm, consUnderscore, consFailed,
eval, showTerm, ($$),
IO',Prim(..),StepPrim,
addConsole,addReadFile,addWrittenFile,getNextExtVal,
addConsole,
addReadFile,addWrittenFile,addAppendedFile,
getNextExtVal,
pc1,pc2,pc3,pc4,pc5
) where
......@@ -162,7 +164,8 @@ data DebuggerState = DebuggerState {
-- Durchlauf geskippt?
unrated :: BoolStack, -- welche Funktionsaufrufe wurden bei den
-- letzten Durchlufen geskippt?
gui :: Maybe Handle, -- our link to the biotope
gui :: Maybe (Handle,ProcessHandle),
-- our link to the biotope
extValues :: [String] -- the values from external io functions
}
......@@ -320,39 +323,6 @@ eval a mode
--------------------------------------------------------- -}
traceWithStepfile :: StrictCurry a => String -> Step a -> IO ()
traceWithStepfile name program = do
state <- initState name
traceProgram (traceFunCall (return $ consTerm "main" []) program) state
data Prim a = Prim ConsTerm a | PrimUnderscore | PrimFailed String
instance StrictCurry (Prim a) where
showCons PrimUnderscore = return consUnderscore
showCons (PrimFailed s) = return (consFailed s)
showCons (Prim a _) = return a
instance Eq (Prim a) where
Prim x _ == Prim y _ = x Prelude.== y
instance Show (Prim a) where
show (Prim a _) = show a
type IO' a = Prim (Step a)
type StepPrim a = Step (Prim a)
runWithStepfile :: StrictCurry a => String -> Step (IO' a) -> IO ()
runWithStepfile name action = do
state <- initState name
bug <- runErrorT $ runStateT (do Prim term act <- action StepInteractive
b <- act StepInteractive
closeGui
return b) state
hSetEcho stdin True
report bug
{-
loadStepfile laedt eine Orakelliste aus einer Datei
make initial output and set terminal properties
......@@ -407,6 +377,36 @@ traceLoop program
else do put $ state { unrated = reverse (skipped endState) }
traceLoop program)
traceWithStepfile :: StrictCurry a => String -> Step a -> IO ()
traceWithStepfile name program = do
state <- initState name
traceProgram (traceFunCall (return $ consTerm "main" []) program) state
runWithStepfile :: StrictCurry a => String -> Step (IO' a) -> IO ()
runWithStepfile name action = do
state <- initState name
bug <- runErrorT $ runStateT (ioLoop action) state
hSetEcho stdin True
report bug
ioLoop :: Step (IO' a) -> DebugMonad a
ioLoop action = do state <- get
put $ state { skipped = emptyBoolStack }
Prim term act <- action StepInteractive
b <- act StepInteractive
endState <- get
if sum (skipped endState) == 0
then closeGui >> return b
else do liftIO $ putStrLn "end reached. press any key to restart." >>
getChar
resetGui
put $ state { unrated = reverse (skipped endState),
gui = gui endState }
ioLoop action
{-
Im instrumentierten Programm sind alle Funktionsaufrufe,
......@@ -535,7 +535,25 @@ showMenu menu = do state <- get
usageLine (' ', (s, _)) = " <SPACE> " ++ s
usageLine (c, (s,_ )) = " "++ c:" " ++ s
---------------------------------------------------------------
-- representation of external data types
---------------------------------------------------------------
data Prim a = Prim ConsTerm a | PrimUnderscore | PrimFailed String
instance StrictCurry (Prim a) where
showCons PrimUnderscore = return consUnderscore
showCons (PrimFailed s) = return (consFailed s)
showCons (Prim a _) = return a
instance Eq (Prim a) where
Prim x _ == Prim y _ = x Prelude.== y
instance Show (Prim a) where
show (Prim a _) = show a
type IO' a = Prim (Step a)
type StepPrim a = Step (Prim a)
---------------------------------------------------------------
-- saved values of external functions and their representation
......@@ -551,29 +569,44 @@ getGuiHandle :: DebugMonad Handle
getGuiHandle = do
st <- get
case gui st of
Nothing -> do h <- liftIO $ do
(h,_,_,_) <- runInteractiveCommand "biogui"
return h
put (st{gui=Just h})
return h
Just h -> do op <- liftIO (hIsOpen h)
if not op then put (st{gui=Nothing}) >>
getGuiHandle
else return h
Nothing -> do hs <- liftIO $ do
(h,_,_,ex) <- runInteractiveCommand "biotope"
return (h,ex)
put (st{gui=Just hs})
return (fst hs)
Just (h,ex) -> do
mc <- liftIO $ getProcessExitCode ex
case mc of
Nothing -> return h
Just _ -> do
liftIO $ putStrLn "restarting biotype. old\
\values are not available."
put (st{gui=Nothing})
getGuiHandle
closeGui :: DebugMonad ()
closeGui = do
closeGui = putIfAlive 'q'
resetGui :: DebugMonad ()
resetGui = putIfAlive '!'
putIfAlive :: Char -> DebugMonad ()
putIfAlive c = do
st <- get
maybe (return ()) (\ h -> liftIO (hPutChar h 'q' >> hClose h)) (gui st)
maybe (return ())
(\ (h,ex) -> liftIO $ getProcessExitCode ex >>=
maybe (hPutChar h c >> hFlush h)
(\_ -> return ()))
(gui st)
addConsole :: Char -> Step ()
addConsole c = liftDebug $ do
h <- getGuiHandle
liftIO $ hPutStr h ['c',c] >> hFlush h
addReadFile, addWrittenFile :: String -> String -> Step ()
addReadFile = addFile 'r'
addWrittenFile = addFile 'w'
addReadFile, addWrittenFile, addAppendedFile :: String -> String -> Step ()
addReadFile = addFile 'r'
addWrittenFile = addFile 'w'
addAppendedFile = addFile 'a'
addFile :: Char -> String -> String -> Step ()
addFile c fn cont = liftDebug $ do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment