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) ...@@ -142,9 +142,11 @@ prim_readFile = ioFunc1 "prim_readFile" (extVal `dot` addReadFile)
prim_writeFile :: String -> String -> Step (IO ()) prim_writeFile :: String -> String -> Step (IO ())
prim_writeFile = ioFunc2 "prim_writeFile" addWrittenFile 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 :: StrictCurry a => a -> Step String
prim_show = trace1 "prim_show" Prelude.show prim_show = trace1 "prim_show" Prelude.show
......
...@@ -12,25 +12,23 @@ hello= listToDeq ...@@ -12,25 +12,23 @@ hello= listToDeq
\(____/()(____)()(_____)() Oracles\n\ \(____/()(____)()(_____)() Oracles\n\
\---------------------------------\n\n\n" \---------------------------------\n\n\n"
widget st lref ref cb rb wb act = Col [LeftAlign] [ widget st lref ref cb fb act = Col [LeftAlign] [
Row [] [PlainButton [Text "Console",WRef cb,Active (act==Console), row [PlainButton [Text "Console",WRef cb,Active (act==Console),
Handler DefaultEvent (showConsole st)], Handler DefaultEvent (showConsole st)],
PlainButton [Text "Files read",Active (act==ReadFiles),WRef rb, PlainButton [Text "Files",Active (act==Files),WRef fb,
Handler DefaultEvent (showReadFile st 0)], Handler DefaultEvent (showFile True st 0)]],
PlainButton [Text "Files written",Active (act==WrittenFiles),WRef wb, row [ListBox [FillY,Width 0,WRef lref,
Handler DefaultEvent (showWrittenFile st 0)]], Handler DefaultEvent (selectFile st)],
Row [] [ListBox [FillY,Width 0,WRef lref, TextEditScroll [Text $ deqToList hello,WRef ref]]
Handler DefaultEvent (selectFile st)],
TextEditScroll [Text $ deqToList hello,WRef ref,TclOption ""]]
] ]
main = do main = do
let cref,rb,wb,lref,cb free let cref,fb,lref,cb free
stdinUnbuffered stdinUnbuffered
state <- newIORef (emptyState cref rb wb lref cb) state <- newIORef (emptyState cref fb lref cb)
runInitHandlesControlledGUI "B.I.O.tope -- the debugging environment" 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] (readMessages state stdin) [stdin]
...@@ -38,29 +36,27 @@ main = do ...@@ -38,29 +36,27 @@ main = do
-- the state and how to reset it -- the state and how to reset it
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
data ActiveWidget = Console | ReadFiles | WrittenFiles data ActiveWidget = Console | Files
type Files = [(String,String)] type Files = [(String,String)]
type State = {readFiles, writtenFiles :: Files, type State = {files :: Files,
console :: Queue Char,active :: ActiveWidget, console :: Queue Char,active :: ActiveWidget,
listWidget,textWidget, listWidget,textWidget,
consoleButton,readButton,writtenButton :: WidgetRef} consoleButton,fileButton :: WidgetRef}
emptyState r1 r2 r3 r4 r5 = emptyState r1 r2 r3 r4 =
{readFiles=[],writtenFiles=[],console=hello, active=Console, {files=[],console=hello, active=Console,
textWidget=r1,readButton=r2,writtenButton=r3, textWidget=r1,fileButton=r2,
listWidget=r4,consoleButton=r5} listWidget=r3,consoleButton=r4}
reset :: GuiPort -> IORef State -> IO [ReconfigureItem] reset :: GuiPort -> IORef State -> IO [ReconfigureItem]
reset gp ref = do reset gp ref = do
st <- readIORef ref st <- readIORef ref
writeIORef ref {readFiles:=[],writtenFiles:=[],console:=hello, writeIORef ref {files:=[],console:=hello,active:=Console|st}
active:=Console|st}
setValue (st->textWidget) (deqToList hello) gp setValue (st->textWidget) (deqToList hello) gp
return [WidgetConf (st->listWidget) (List []), return [WidgetConf (st->listWidget) (List []),
acti False (st->readButton), acti False (st->fileButton),
acti False (st->writtenButton),
acti False (st->consoleButton)] acti False (st->consoleButton)]
...@@ -81,17 +77,21 @@ addConsole gp ref c = do ...@@ -81,17 +77,21 @@ addConsole gp ref c = do
WidgetConf (st->listWidget) (List [])] WidgetConf (st->listWidget) (List [])]
addReadFile :: GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem] addFile :: Bool -> GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem]
addReadFile gp ref f = do addFile append gp ref f@(fn,cont) = do
st <- readIORef ref st <- readIORef ref
writeIORef ref {readFiles:=st->readFiles++[f] | st} let fs = st->files
showReadFile ref (length (st->readFiles)) gp case break ((==tail fn) . tail . fst) fs of
(_,[]) -> do
addWrittenFile :: GuiPort -> IORef State -> (String,String) -> IO [ReconfigureItem] writeIORef ref {files:=st->files++[f] | st}
addWrittenFile gp ref f = do showFile True ref (length (st->files)) gp
st <- readIORef ref (xs,(y,yc):ys) -> if append
writeIORef ref {writtenFiles:=st->writtenFiles ++ [f] | st} then do
showWrittenFile ref (length (st->writtenFiles)) gp 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 -- showing content in text/list widget
...@@ -101,25 +101,18 @@ selectFile :: IORef State -> GuiPort -> IO [ReconfigureItem] ...@@ -101,25 +101,18 @@ selectFile :: IORef State -> GuiPort -> IO [ReconfigureItem]
selectFile ref gp = do selectFile ref gp = do
st <- readIORef ref st <- readIORef ref
i <- getValue (st->listWidget) gp i <- getValue (st->listWidget) gp
case st->active of showFile False ref (readInt i) gp
ReadFiles -> showReadFile ref (readInt i) gp
WrittenFiles -> showWrittenFile ref (readInt i) gp
showReadFile :: IORef State -> Int -> GuiPort -> IO [ReconfigureItem] showFile :: Bool -> IORef State -> Int -> GuiPort -> IO [ReconfigureItem]
showReadFile ref i gp = do showFile listchanged ref i gp = do
st <- readIORef ref st <- readIORef ref
setValue (st->textWidget) (snd (st->readFiles !! i)) gp setValue (st->textWidget) (snd (st->files !! i)) gp
writeIORef ref {active:=ReadFiles|st} writeIORef ref {active:=Files|st}
return [activate st,acti False (st->readButton), return (activate st:acti False (st->fileButton):
WidgetConf (st->listWidget) (List (map fst (st->readFiles)))] if listchanged
then map (WidgetConf (st->listWidget))
showWrittenFile :: IORef State -> Int -> GuiPort -> IO [ReconfigureItem] [List (map fst (st->files)),Text (show i)]
showWrittenFile ref i gp = do else [])
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)))]
showConsole :: IORef State -> GuiPort -> IO [ReconfigureItem] showConsole :: IORef State -> GuiPort -> IO [ReconfigureItem]
showConsole ref gp = do showConsole ref gp = do
...@@ -131,9 +124,8 @@ showConsole ref gp = do ...@@ -131,9 +124,8 @@ showConsole ref gp = do
activate :: State -> ReconfigureItem activate :: State -> ReconfigureItem
activate st = acti True (case st -> active of activate st = acti True (case st -> active of
ReadFiles -> (st->readButton) Files -> (st->fileButton)
WrittenFiles -> (st->writtenButton) Console -> (st->consoleButton))
Console -> (st->consoleButton))
acti b ref = WidgetConf ref (Active b) acti b ref = WidgetConf ref (Active b)
...@@ -152,11 +144,15 @@ readMessages ref h gp = do ...@@ -152,11 +144,15 @@ readMessages ref h gp = do
'r' -> do 'r' -> do
l <- hGetLine h l <- hGetLine h
cont <- getFileCont h cont <- getFileCont h
addReadFile gp ref (l,cont) addFile False gp ref ("R: "++l,cont)
'w' -> do 'w' -> do
l <- hGetLine h l <- hGetLine h
cont <- getFileCont 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 [] 'q' -> exitGUI gp >> return []
'!' -> reset gp ref '!' -> reset gp ref
_ -> return [] _ -> return []
......
...@@ -6,7 +6,9 @@ module StrictSteps ( ...@@ -6,7 +6,9 @@ module StrictSteps (
ConsTerm, consTerm, consUnderscore, consFailed, ConsTerm, consTerm, consUnderscore, consFailed,
eval, showTerm, ($$), eval, showTerm, ($$),
IO',Prim(..),StepPrim, IO',Prim(..),StepPrim,
addConsole,addReadFile,addWrittenFile,getNextExtVal, addConsole,
addReadFile,addWrittenFile,addAppendedFile,
getNextExtVal,
pc1,pc2,pc3,pc4,pc5 pc1,pc2,pc3,pc4,pc5
) where ) where
...@@ -162,7 +164,8 @@ data DebuggerState = DebuggerState { ...@@ -162,7 +164,8 @@ data DebuggerState = DebuggerState {
-- Durchlauf geskippt? -- Durchlauf geskippt?
unrated :: BoolStack, -- welche Funktionsaufrufe wurden bei den unrated :: BoolStack, -- welche Funktionsaufrufe wurden bei den
-- letzten Durchlufen geskippt? -- 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 extValues :: [String] -- the values from external io functions
} }
...@@ -320,39 +323,6 @@ eval a mode ...@@ -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 loadStepfile laedt eine Orakelliste aus einer Datei
make initial output and set terminal properties make initial output and set terminal properties
...@@ -407,6 +377,36 @@ traceLoop program ...@@ -407,6 +377,36 @@ traceLoop program
else do put $ state { unrated = reverse (skipped endState) } else do put $ state { unrated = reverse (skipped endState) }
traceLoop program) 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, Im instrumentierten Programm sind alle Funktionsaufrufe,
...@@ -535,7 +535,25 @@ showMenu menu = do state <- get ...@@ -535,7 +535,25 @@ showMenu menu = do state <- get
usageLine (' ', (s, _)) = " <SPACE> " ++ s usageLine (' ', (s, _)) = " <SPACE> " ++ s
usageLine (c, (s,_ )) = " "++ c:" " ++ 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 -- saved values of external functions and their representation
...@@ -551,29 +569,44 @@ getGuiHandle :: DebugMonad Handle ...@@ -551,29 +569,44 @@ getGuiHandle :: DebugMonad Handle
getGuiHandle = do getGuiHandle = do
st <- get st <- get
case gui st of case gui st of
Nothing -> do h <- liftIO $ do Nothing -> do hs <- liftIO $ do
(h,_,_,_) <- runInteractiveCommand "biogui" (h,_,_,ex) <- runInteractiveCommand "biotope"
return h return (h,ex)
put (st{gui=Just h}) put (st{gui=Just hs})
return h return (fst hs)
Just h -> do op <- liftIO (hIsOpen h) Just (h,ex) -> do
if not op then put (st{gui=Nothing}) >> mc <- liftIO $ getProcessExitCode ex
getGuiHandle case mc of
else return h Nothing -> return h
Just _ -> do
liftIO $ putStrLn "restarting biotype. old\
\values are not available."
put (st{gui=Nothing})
getGuiHandle
closeGui :: DebugMonad () closeGui :: DebugMonad ()
closeGui = do closeGui = putIfAlive 'q'
resetGui :: DebugMonad ()
resetGui = putIfAlive '!'
putIfAlive :: Char -> DebugMonad ()
putIfAlive c = do
st <- get 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 :: Char -> Step ()
addConsole c = liftDebug $ do addConsole c = liftDebug $ do
h <- getGuiHandle h <- getGuiHandle
liftIO $ hPutStr h ['c',c] >> hFlush h liftIO $ hPutStr h ['c',c] >> hFlush h
addReadFile, addWrittenFile :: String -> String -> Step () addReadFile, addWrittenFile, addAppendedFile :: String -> String -> Step ()
addReadFile = addFile 'r' addReadFile = addFile 'r'
addWrittenFile = addFile 'w' addWrittenFile = addFile 'w'
addAppendedFile = addFile 'a'
addFile :: Char -> String -> String -> Step () addFile :: Char -> String -> String -> Step ()
addFile c fn cont = liftDebug $ do 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