Commit 7ecfe31c authored by bbr's avatar bbr
Browse files

marginal improvements

parent 013a31f0
...@@ -33,7 +33,7 @@ consFailed = Fail ...@@ -33,7 +33,7 @@ consFailed = Fail
-- catch the underscore exception. -- catch the underscore exception.
class (Show a,Eq a) => ShowTerm a where class (Show a,Eq a) => ShowTerm a where
showCons :: a -> Debug Term showCons :: a -> DebugM Term
showCons x = return (Term (show x) []) showCons x = return (Term (show x) [])
underscore :: a underscore :: a
...@@ -42,7 +42,7 @@ underscore = throw NonTermination ...@@ -42,7 +42,7 @@ underscore = throw NonTermination
failure :: String -> a failure :: String -> a
failure s = throw (ErrorCall s) failure s = throw (ErrorCall s)
showTerm :: ShowTerm a => a -> Debug Term showTerm :: ShowTerm a => a -> DebugM Term
showTerm x = do showTerm x = do
st <- getDisplayMode st <- getDisplayMode
case depth st of case depth st of
...@@ -53,7 +53,7 @@ showTerm x = do ...@@ -53,7 +53,7 @@ showTerm x = do
modifyDisplayMode (const st) modifyDisplayMode (const st)
return res return res
showHead :: ShowTerm a => a -> Debug Term showHead :: ShowTerm a => a -> DebugM Term
showHead x = showHead x =
liftIO (catch (x `seq` return Nothing) (return . Just)) >>= liftIO (catch (x `seq` return Nothing) (return . Just)) >>=
maybe (showCons x) maybe (showCons x)
...@@ -64,7 +64,7 @@ showHead x = ...@@ -64,7 +64,7 @@ showHead x =
($$) :: ShowTerm a => Debug [Term] -> a -> Debug [Term] ($$) :: ShowTerm a => DebugM [Term] -> a -> DebugM [Term]
getxs $$ x = do getxs $$ x = do
xs <- getxs xs <- getxs
x <- showTerm x x <- showTerm x
...@@ -128,7 +128,11 @@ push bs False = 0 : bs ...@@ -128,7 +128,11 @@ push bs False = 0 : bs
-} -}
type Debug a = StateT DebugState (ErrorT BugReport Prelude.IO) a type DebugM a = StateT DebugState (ErrorT BugReport Prelude.IO) a
type Debug a = DebugM (Data a)
-- a BugReport is the left hand side + result -- a BugReport is the left hand side + result
...@@ -225,53 +229,61 @@ data DebugState = DebugState { ...@@ -225,53 +229,61 @@ data DebugState = DebugState {
setDepth :: Maybe Int -> DisplayMode -> DisplayMode setDepth :: Maybe Int -> DisplayMode -> DisplayMode
setDepth d m = m{depth=d} setDepth d m = m{depth=d}
getDisplayMode :: Debug DisplayMode getDisplayMode :: DebugM DisplayMode
getDisplayMode = do getDisplayMode = do
state <- get state <- get
liftIO $ readIORef (displayMode state) liftIO $ readIORef (displayMode state)
modifyDisplayMode :: (DisplayMode -> DisplayMode) -> Debug () modifyDisplayMode :: (DisplayMode -> DisplayMode) -> DebugM ()
modifyDisplayMode f = do modifyDisplayMode f = do
state <- get state <- get
liftIO $ modifyIORef (displayMode state) f liftIO $ modifyIORef (displayMode state) f
--------------------------------------------------------------- ---------------------------------------------------------------
-- representation of external data types -- representation of internal data types
--------------------------------------------------------------- ---------------------------------------------------------------
data Prim a = Prim Term a data Data a = C0_1 | C1_1 (Data a) | C2_1 (Data a) (Data a)
| C3_1 (Data a) (Data a) (Data a)
| C0_2 | C1_2 (Data a) | C2_2 (Data a) (Data a)
| C3_2 (Data a) (Data a) (Data a)
| C0_3 | C1_3 (Data a) | C2_3 (Data a) (Data a)
| C3_3 (Data a) (Data a) (Data a)
| Char Char
| Float Float
| C0_ Int | C1_ Int (Data a) | C2_ Int (Data a) (Data a)
| C3_ Int (Data a) (Data a) (Data a)
| C Int (Data a) (Data a) (Data a) (Data a) [Data a]
| Prim Term a
| Uneval
| Or [Data a] deriving Eq
---------------------------------------------------------------
-- representation of external data types
---------------------------------------------------------------
unprim :: Prim a -> a unprim :: Data a -> a
unprim (Prim _ x) = x unprim (Prim _ x) = x
instance (Eq a,Show a) => ShowTerm (Prim a) where instance ShowTerm (Data (a -> b)) where
showCons (Prim a _) = getDisplayMode >>= return . depth >>= showCons (Prim a _) = getDisplayMode >>= return . depth >>=
return . maybe a (restrict a) return . maybe a (restrict a)
instance Eq a => Eq (Prim a) where instance Show (Data (a -> b)) where
Prim _ x == Prim _ y = x Prelude.== y
instance Show a => Show (Prim a) where
show (Prim _ a) = show a show (Prim _ a) = show a
type DebugPrim a = Debug (Prim a) type DebugPrim a = Debug a
type Prim a = Data a
data World = World deriving (Show,Eq) data World = World deriving (Show,Eq)
instance ShowTerm World where world = C0_1
showCons World = return (consTerm "#world" [])
data IOAction a = IO (Debug Term) (Debug a)
| PrimIO (Debug Term) (Debug a)
isPrimIO :: IOAction a -> Bool instance ShowTerm (Data World) where
isPrimIO (PrimIO _ _) = True
isPrimIO (IO _ _) = False
action :: IOAction a -> Debug a instance Show (Data World) where
action (PrimIO _ x) = x show C0_1 = "#world"
action (IO _ x) = x
-- these must be conform with ExternalInstancesPrelude.hs -- these must be conform with ExternalInstancesPrelude.hs
......
...@@ -30,8 +30,8 @@ type ProgAct a = Path -> [a] -> Prog -> IO a ...@@ -30,8 +30,8 @@ type ProgAct a = Path -> [a] -> Prog -> IO a
type Done a = IORef (FM String a) type Done a = IORef (FM String a)
--- calls act on each imported module transitevely --- calls act on each imported module transitively
--- if test was True. --- if test returns Nothing.
make :: ModuleName -> TestAct a -> ProgAct a -> IO () make :: ModuleName -> TestAct a -> ProgAct a -> IO ()
make modu test act = do make modu test act = do
putStrLn "ensuring existence of fcy/fint files..." putStrLn "ensuring existence of fcy/fint files..."
......
...@@ -8,7 +8,7 @@ module StrictSteps ( ...@@ -8,7 +8,7 @@ module StrictSteps (
Term, consTerm, consUnderscore, consFailed, Term, consTerm, consUnderscore, consFailed,
eval, oneStep, showTerm, ($$), ShowTerm(..), eval, oneStep, showTerm, ($$), ShowTerm(..),
DM.IOAction(..),isPrimIO,action,Prim(..),DebugPrim, Prim,DebugPrim,Data(..),
Debug,World(..), Debug,World(..),
addConsole, addConsole,
...@@ -21,7 +21,7 @@ module StrictSteps ( ...@@ -21,7 +21,7 @@ module StrictSteps (
import Prelude hiding (catch,interact) import Prelude hiding (catch,interact)
import System.IO.Unsafe import System.IO.Unsafe
import DebuggerMonad hiding (IO) import DebuggerMonad
import qualified DebuggerMonad as DM import qualified DebuggerMonad as DM
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State import Control.Monad.State
...@@ -49,13 +49,13 @@ toggleVerbosity, toggleInspectMode :: DisplayMode -> DisplayMode ...@@ -49,13 +49,13 @@ toggleVerbosity, toggleInspectMode :: DisplayMode -> DisplayMode
toggleVerbosity m = m {verbose = not (verbose m)} toggleVerbosity m = m {verbose = not (verbose m)}
toggleInspectMode m = m {optionalResult = not (optionalResult m)} toggleInspectMode m = m {optionalResult = not (optionalResult m)}
pushPast :: Bool -> Debug () pushPast :: Bool -> DebugM ()
pushPast b = modify (\s -> s { past = push (past s) b }) pushPast b = modify (\s -> s { past = push (past s) b })
-- each step in the debugger shifts one boolean -- each step in the debugger shifts one boolean
-- value from the future to the past. -- value from the future to the past.
-- we want to know what the shifted value was. -- we want to know what the shifted value was.
shift :: Debug Bool shift :: DebugM Bool
shift = do shift = do
state <- get state <- get
let (stack, entry) = pop (future state) let (stack, entry) = pop (future state)
...@@ -63,7 +63,7 @@ shift = do ...@@ -63,7 +63,7 @@ shift = do
past = push (past state) entry} past = push (past state) entry}
return entry return entry
eval :: Debug a -> Debug a eval :: DebugM a -> DebugM a
eval act = do eval act = do
printOrc printOrc
state <- get state <- get
...@@ -71,16 +71,16 @@ eval act = do ...@@ -71,16 +71,16 @@ eval act = do
put (state {oracle = orc}) put (state {oracle = orc})
if needed then act else return underscore if needed then act else return underscore
oneStep :: Debug (Prim ()) oneStep :: DebugM ()
oneStep = eval (return undefined) oneStep = eval (return ())
putCorrect :: Bool -> Debug () putCorrect :: Bool -> DebugM ()
putCorrect b = do {st <- get; put st{correct=b}} putCorrect b = do {st <- get; put st{correct=b}}
putSilent :: Bool -> Debug () putSilent :: Bool -> DebugM ()
putSilent b = do {st <- get; put st{interactive=not b,mainthread=not b}} putSilent b = do {st <- get; put st{interactive=not b,mainthread=not b}}
evalWith :: (Bool -> Debug ()) -> Debug a -> Debug a evalWith :: (Bool -> DebugM ()) -> DebugM a -> DebugM a
evalWith setter expr = do evalWith setter expr = do
setter True setter True
r <- eval expr r <- eval expr
...@@ -92,7 +92,7 @@ evalWith setter expr = do ...@@ -92,7 +92,7 @@ evalWith setter expr = do
-- every function call in the program is instrumented with a -- every function call in the program is instrumented with a
-- call to this function. -- call to this function.
traceFunCall :: ShowTerm a => Debug Term -> Debug a -> Debug a traceFunCall :: ShowTerm a => DebugM Term -> DebugM a -> DebugM a
traceFunCall call expr = do traceFunCall call expr = do
printOrc printOrc
st <- get st <- get
...@@ -110,7 +110,7 @@ traceFunCall call expr = do ...@@ -110,7 +110,7 @@ traceFunCall call expr = do
inspector :: ShowTerm a => Debug Term -> Debug a -> Debug a inspector :: ShowTerm a => DebugM Term -> DebugM a -> DebugM a
inspector call expr = do inspector call expr = do
origState <- get origState <- get
result <- evalWith putSilent expr result <- evalWith putSilent expr
...@@ -129,7 +129,7 @@ inspector call expr = do ...@@ -129,7 +129,7 @@ inspector call expr = do
,(' ',(True,"step into",put origState >> eval expr))] ,(' ',(True,"step into",put origState >> eval expr))]
stepper :: ShowTerm a => Debug Term -> Debug a -> Debug a stepper :: ShowTerm a => DebugM Term -> DebugM a -> DebugM a
stepper call expr = stepper call expr =
interact (nl >> showCall call) interact (nl >> showCall call)
[('r',(False,"inspect result",inspector call expr)) [('r',(False,"inspect result",inspector call expr))
...@@ -141,16 +141,16 @@ stepper call expr = ...@@ -141,16 +141,16 @@ stepper call expr =
,step call expr] ,step call expr]
type Option a = (Char,(Bool,String,Debug a)) type Option a = (Char,(Bool,String,DebugM a))
right :: Debug () -> Debug a -> DebugState -> Option a right :: DebugM () -> DebugM a -> DebugState -> Option a
right repaint expr state = ('c', (True,"correct",do right repaint expr state = ('c', (True,"correct",do
put (state {past=push (fst (pop (past state))) False}) put (state {past=push (fst (pop (past state))) False})
withColor green repaint withColor green repaint
evalWith putCorrect expr)) evalWith putCorrect expr))
wrong :: ShowTerm a => Debug () -> a -> DebugState -> Debug Term wrong :: ShowTerm a => DebugM () -> a -> DebugState -> DebugM Term
-> Debug a -> Option a -> DebugM a -> Option a
wrong repaint result state call expr = ('w', (True,"wrong",do wrong repaint result state call expr = ('w', (True,"wrong",do
put state put state
withColor red repaint withColor red repaint
...@@ -160,7 +160,7 @@ wrong repaint result state call expr = ('w', (True,"wrong",do ...@@ -160,7 +160,7 @@ wrong repaint result state call expr = ('w', (True,"wrong",do
closeGui closeGui
throwError (BugReport {lhs=l,rhs=r}))) throwError (BugReport {lhs=l,rhs=r})))
skip :: ShowTerm a => Debug a -> Option a skip :: ShowTerm a => DebugM a -> Option a
skip expr = ('s', (True,"skip",do skip expr = ('s', (True,"skip",do
st <- get st <- get
put st{interactive=False,mainthread=True,correct=False} put st{interactive=False,mainthread=True,correct=False}
...@@ -175,7 +175,7 @@ skip expr = ('s', (True,"skip",do ...@@ -175,7 +175,7 @@ skip expr = ('s', (True,"skip",do
nl nl
return r)) return r))
step :: ShowTerm a => Debug Term -> Debug a -> Option a step :: ShowTerm a => DebugM Term -> DebugM a -> Option a
step call expr = (' ', (True,"step into",do step call expr = (' ', (True,"step into",do
nl nl
r <- eval expr r <- eval expr
...@@ -184,14 +184,14 @@ step call expr = (' ', (True,"step into",do ...@@ -184,14 +184,14 @@ step call expr = (' ', (True,"step into",do
nl nl
return r)) return r))
stepBack :: Debug a -> Option a stepBack :: DebugM a -> Option a
stepBack noop = ('b', (False,"back",do stepBack noop = ('b', (False,"back",do
st <- get; st <- get;
if null (history st) if null (history st)
then noop then noop
else do {nl; throwError $ Back $ reverse $ tail $ history st})) else do {nl; throwError $ Back $ reverse $ tail $ history st}))
printOrc :: Debug () printOrc :: DebugM ()
printOrc = do printOrc = do
st <- get st <- get
dm <- getDisplayMode dm <- getDisplayMode
...@@ -206,7 +206,7 @@ printOrc = do ...@@ -206,7 +206,7 @@ printOrc = do
putStr $ " main: " ++ show (mainthread st)) putStr $ " main: " ++ show (mainthread st))
else return () else return ()
interact :: Debug () -> [Option a] -> Debug a interact :: DebugM () -> [Option a] -> DebugM a
interact repaint men = do interact repaint men = do
st <- get st <- get
input <- getRewindChar input <- getRewindChar
...@@ -221,7 +221,7 @@ interact repaint men = do ...@@ -221,7 +221,7 @@ interact repaint men = do
usageLine (' ', (_,s,_)) = " <SPACE> " ++ s usageLine (' ', (_,s,_)) = " <SPACE> " ++ s
usageLine (c, (_,s,_)) = " "++ c:" " ++ s usageLine (c, (_,s,_)) = " "++ c:" " ++ s
standardOptions :: Debug () -> [Option a] -> [Option a] standardOptions :: DebugM () -> [Option a] -> [Option a]
standardOptions repaint menu = [ standardOptions repaint menu = [
('v',(False,"toggle verbosity", modifyDisplayMode toggleVerbosity >> ('v',(False,"toggle verbosity", modifyDisplayMode toggleVerbosity >>
repaint >> repaint >>
...@@ -233,14 +233,14 @@ standardOptions repaint menu = [ ...@@ -233,14 +233,14 @@ standardOptions repaint menu = [
interact repaint menu)) interact repaint menu))
] ]
addToHistory :: Bool -> Char -> Debug a -> Debug a addToHistory :: Bool -> Char -> DebugM a -> DebugM a
addToHistory False _ a = a addToHistory False _ a = a
addToHistory True c a = do addToHistory True c a = do
st <- get st <- get
put st{history=c:history st} put st{history=c:history st}
a a
getRewindChar :: Debug Char getRewindChar :: DebugM Char
getRewindChar = do getRewindChar = do
st <- get st <- get
if rewinding st if rewinding st
...@@ -252,10 +252,10 @@ getRewindChar = do ...@@ -252,10 +252,10 @@ getRewindChar = do
return c return c
else liftIO getChar else liftIO getChar
nl :: Debug () nl :: DebugM ()
nl = liftIO (putChar '\n') nl = liftIO (putChar '\n')
getDepth :: Debug (Maybe Int) getDepth :: DebugM (Maybe Int)
getDepth = do getDepth = do
d <- getDisplayMode >>= return . depth d <- getDisplayMode >>= return . depth
liftIO $ do liftIO $ do
...@@ -328,7 +328,7 @@ initState isIO name ...@@ -328,7 +328,7 @@ initState isIO name
bis alle Funktionsaufrufe bewertet sind oder ein Bug bis alle Funktionsaufrufe bewertet sind oder ein Bug
gefunden wurde. gefunden wurde.
-} -}
traceProgram :: Debug a -> DebugState -> IO () traceProgram :: DebugM a -> DebugState -> IO ()
traceProgram debugloop state = do traceProgram debugloop state = do
bug <- runErrorT $ runStateT debugloop state bug <- runErrorT $ runStateT debugloop state
report state debugloop bug report state debugloop bug
...@@ -339,7 +339,7 @@ traceProgram debugloop state = do ...@@ -339,7 +339,7 @@ traceProgram debugloop state = do
darin alle Funktionsaufrufe bewertet sind oder ein darin alle Funktionsaufrufe bewertet sind oder ein
fehlerhafter Aufruf gefunden wurde. fehlerhafter Aufruf gefunden wurde.
-} -}
traceLoop :: Debug a -> Debug a traceLoop :: DebugM a -> DebugM a
traceLoop program traceLoop program
= do state <- get = do state <- get
put $ state { past=emptyBoolStack } put $ state { past=emptyBoolStack }
...@@ -364,7 +364,7 @@ traceLoop program ...@@ -364,7 +364,7 @@ traceLoop program
rewind = rewind endState} rewind = rewind endState}
traceLoop program traceLoop program
traceWithStepfile :: ShowTerm a => String -> Debug a -> IO () traceWithStepfile :: ShowTerm a => String -> DebugM a -> IO ()
traceWithStepfile name program = traceWithStepfile name program =
initState False name >>= initState False name >>=
traceProgram (traceLoop $ traceFunCall (return $ consTerm "main" []) program) traceProgram (traceLoop $ traceFunCall (return $ consTerm "main" []) program)
...@@ -374,18 +374,18 @@ runWithStepfile :: ShowTerm a => String -> (IO' a) -> IO () ...@@ -374,18 +374,18 @@ runWithStepfile :: ShowTerm a => String -> (IO' a) -> IO ()
runWithStepfile name action = runWithStepfile name action =
initState True name >>= traceProgram (ioLoop action) initState True name >>= traceProgram (ioLoop action)
ioLoop :: ShowTerm a => IO' a -> Debug a ioLoop :: ShowTerm a => IO' a -> DebugM a
ioLoop action = traceLoop (action >>= \ x -> unprim x World) ioLoop action = traceLoop (action >>= \ x -> unprim x World)
-- for untrusted applications -- for untrusted applications
bangApp :: (ShowTerm a,ShowTerm b) => String -> (Prim (a -> Debug b)) -> a -> Debug b bangApp :: (ShowTerm a,ShowTerm b) => String -> (Prim (a -> DebugM b)) -> a -> DebugM b
bangApp s f x = traceFunCall (do bangApp s f x = traceFunCall (do
sx1 <- showTerm f sx1 <- showTerm f
sx2 <- showTerm x sx2 <- showTerm x
return (consTerm s [sx1,sx2])) (unprim f x) return (consTerm s [sx1,sx2])) (unprim f x)
-- for trusted applications -- for trusted applications
app :: Prim (a -> Debug b) -> a -> Debug b app :: Prim (a -> DebugM b) -> a -> DebugM b
app f x = eval (unprim f x) app f x = eval (unprim f x)
...@@ -402,7 +402,7 @@ banner :: IO () ...@@ -402,7 +402,7 @@ banner :: IO ()
banner = putStrLn hello >> putStrLn "" banner = putStrLn hello >> putStrLn ""
report :: DebugState -> Debug a -> Either BugReport b -> IO () report :: DebugState -> DebugM a -> Either BugReport b -> IO ()
report state debugloop bug = do report state debugloop bug = do
hSetEcho stdin True hSetEcho stdin True
case bug of case bug of
...@@ -421,22 +421,22 @@ report state debugloop bug = do ...@@ -421,22 +421,22 @@ report state debugloop bug = do
showCall :: Debug Term -> Debug () showCall :: DebugM Term -> DebugM ()
showCall = printTerm "" showCall = printTerm ""
showResult :: ShowTerm a => a -> Debug () showResult :: ShowTerm a => a -> DebugM ()
showResult res = printTerm " ~> " (showTerm res) showResult res = printTerm " ~> " (showTerm res)
printTerm :: String -> Debug Term -> Debug () printTerm :: String -> DebugM Term -> DebugM ()
printTerm s termAct = do printTerm s termAct = do
t <- termAct t <- termAct
liftIO (putStr (s++show t)) liftIO (putStr (s++show t))
withColor :: String -> Debug () -> Debug () withColor :: String -> DebugM () -> DebugM ()
withColor c act = liftIO (putStr c) >> act >> liftIO (putStr off) withColor c act = liftIO (putStr c) >> act >> liftIO (putStr off)
type IO' a = Debug (Prim (World -> Debug a)) type IO' a = DebugM (Prim (World -> DebugM a))
...@@ -446,13 +446,13 @@ type IO' a = Debug (Prim (World -> Debug a)) ...@@ -446,13 +446,13 @@ type IO' a = Debug (Prim (World -> Debug a))
-- saved values of external functions and their representation -- saved values of external functions and their representation
--------------------------------------------------------------- ---------------------------------------------------------------
liftDebug :: Debug () -> Debug () liftDebugM :: DebugM () -> DebugM ()
liftDebug act = do