Skip to content

GitLab

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

marginal improvements

parent 013a31f0
Hide whitespace changes
Inline Side-by-side
src/oracle/DebuggerMonad.hs
View file @ 7ecfe31c
......@@ -33,7 +33,7 @@ consFailed = Fail
-- catch the underscore exception.
class (Show a,Eq a) => ShowTerm a where
showCons :: a -> Debug Term
showCons :: a -> DebugM Term
showCons x = return (Term (show x) [])
underscore :: a
......@@ -42,7 +42,7 @@ underscore = throw NonTermination
failure :: String -> a
failure s = throw (ErrorCall s)
showTerm :: ShowTerm a => a -> Debug Term
showTerm :: ShowTerm a => a -> DebugM Term
showTerm x = do
st <- getDisplayMode
case depth st of
......@@ -53,7 +53,7 @@ showTerm x = do
modifyDisplayMode (const st)
return res
showHead :: ShowTerm a => a -> Debug Term
showHead :: ShowTerm a => a -> DebugM Term
showHead x =
liftIO (catch (x `seq` return Nothing) (return . Just)) >>=
maybe (showCons x)
......@@ -64,7 +64,7 @@ showHead x =
($$) :: ShowTerm a => Debug [Term] -> a -> Debug [Term]
($$) :: ShowTerm a => DebugM [Term] -> a -> DebugM [Term]
getxs $$ x = do
xs <- getxs
x <- showTerm x
......@@ -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
......@@ -225,53 +229,61 @@ data DebugState = DebugState {
setDepth :: Maybe Int -> DisplayMode -> DisplayMode
setDepth d m = m{depth=d}
getDisplayMode :: Debug DisplayMode
getDisplayMode :: DebugM DisplayMode
getDisplayMode = do
state <- get
liftIO $ readIORef (displayMode state)
modifyDisplayMode :: (DisplayMode -> DisplayMode) -> Debug ()
modifyDisplayMode :: (DisplayMode -> DisplayMode) -> DebugM ()
modifyDisplayMode f = do
state <- get
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
instance (Eq a,Show a) => ShowTerm (Prim a) where
instance ShowTerm (Data (a -> b)) where
showCons (Prim a _) = getDisplayMode >>= return . depth >>=
return . maybe a (restrict a)
instance Eq a => Eq (Prim a) where
Prim _ x == Prim _ y = x Prelude.== y
instance Show a => Show (Prim a) where
instance Show (Data (a -> b)) where
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)
instance ShowTerm World where
showCons World = return (consTerm "#world" [])
data IOAction a = IO (Debug Term) (Debug a)
| PrimIO (Debug Term) (Debug a)
world = C0_1
isPrimIO :: IOAction a -> Bool
isPrimIO (PrimIO _ _) = True
isPrimIO (IO _ _) = False
instance ShowTerm (Data World) where
action :: IOAction a -> Debug a
action (PrimIO _ x) = x
action (IO _ x) = x
instance Show (Data World) where
show C0_1 = "#world"
-- these must be conform with ExternalInstancesPrelude.hs
......
src/oracle/Make.curry
View file @ 7ecfe31c
......@@ -30,8 +30,8 @@ type ProgAct a = Path -> [a] -> Prog -> IO a
type Done a = IORef (FM String a)
--- calls act on each imported module transitevely
--- if test was True.
--- calls act on each imported module transitively
--- if test returns Nothing.
make :: ModuleName -> TestAct a -> ProgAct a -> IO ()
make modu test act = do
putStrLn "ensuring existence of fcy/fint files..."
......
src/oracle/StrictSteps.hs
View file @ 7ecfe31c
......@@ -8,7 +8,7 @@ module StrictSteps (
Term, consTerm, consUnderscore, consFailed,
eval, oneStep, showTerm, ($$), ShowTerm(..),
DM.IOAction(..),isPrimIO,action,Prim(..),DebugPrim,
Prim,DebugPrim,Data(..),
Debug,World(..),
addConsole,
......@@ -21,7 +21,7 @@ module StrictSteps (
import Prelude hiding (catch,interact)
import System.IO.Unsafe
import DebuggerMonad hiding (IO)
import DebuggerMonad
import qualified DebuggerMonad as DM
import Control.Monad.Error
import Control.Monad.State
......@@ -49,13 +49,13 @@ toggleVerbosity, toggleInspectMode :: DisplayMode -> DisplayMode
toggleVerbosity m = m {verbose = not (verbose m)}
toggleInspectMode m = m {optionalResult = not (optionalResult m)}
pushPast :: Bool -> Debug ()
pushPast :: Bool -> DebugM ()
pushPast b = modify (\s -> s { past = push (past s) b })
-- each step in the debugger shifts one boolean
-- value from the future to the past.
-- we want to know what the shifted value was.
shift :: Debug Bool
shift :: DebugM Bool
shift = do
state <- get
let (stack, entry) = pop (future state)
......@@ -63,7 +63,7 @@ shift = do
past = push (past state) entry}
return entry
eval :: Debug a -> Debug a
eval :: DebugM a -> DebugM a
eval act = do
printOrc
state <- get
......@@ -71,16 +71,16 @@ eval act = do
put (state {oracle = orc})
if needed then act else return underscore
oneStep :: Debug (Prim ())
oneStep = eval (return undefined)
oneStep :: DebugM ()
oneStep = eval (return ())
putCorrect :: Bool -> Debug ()
putCorrect :: Bool -> DebugM ()
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}}
evalWith :: (Bool -> Debug ()) -> Debug a -> Debug a
evalWith :: (Bool -> DebugM ()) -> DebugM a -> DebugM a
evalWith setter expr = do
setter True
r <- eval expr
......@@ -92,7 +92,7 @@ evalWith setter expr = do
-- every function call in the program is instrumented with a
-- 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
printOrc
st <- get
......@@ -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
origState <- get
result <- evalWith putSilent expr
......@@ -129,7 +129,7 @@ inspector call expr = do
,(' ',(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 =
interact (nl >> showCall call)
[('r',(False,"inspect result",inspector call expr))
......@@ -141,16 +141,16 @@ stepper 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
put (state {past=push (fst (pop (past state))) False})
withColor green repaint
evalWith putCorrect expr))
wrong :: ShowTerm a => Debug () -> a -> DebugState -> Debug Term
-> Debug a -> Option a
wrong :: ShowTerm a => DebugM () -> a -> DebugState -> DebugM Term
-> DebugM a -> Option a
wrong repaint result state call expr = ('w', (True,"wrong",do
put state
withColor red repaint
......@@ -160,7 +160,7 @@ wrong repaint result state call expr = ('w', (True,"wrong",do
closeGui
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
st <- get
put st{interactive=False,mainthread=True,correct=False}
......@@ -175,7 +175,7 @@ skip expr = ('s', (True,"skip",do
nl
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
nl
r <- eval expr
......@@ -184,14 +184,14 @@ step call expr = (' ', (True,"step into",do
nl
return r))
stepBack :: Debug a -> Option a
stepBack :: DebugM a -> Option a
stepBack noop = ('b', (False,"back",do
st <- get;
if null (history st)
then noop
else do {nl; throwError $ Back $ reverse $ tail $ history st}))
printOrc :: Debug ()
printOrc :: DebugM ()
printOrc = do
st <- get
dm <- getDisplayMode
......@@ -206,7 +206,7 @@ printOrc = do
putStr $ " main: " ++ show (mainthread st))
else return ()
interact :: Debug () -> [Option a] -> Debug a
interact :: DebugM () -> [Option a] -> DebugM a
interact repaint men = do
st <- get
input <- getRewindChar
......@@ -221,7 +221,7 @@ interact repaint men = do
usageLine (' ', (_,s,_)) = " <SPACE> " ++ s
usageLine (c, (_,s,_)) = " "++ c:" " ++ s
standardOptions :: Debug () -> [Option a] -> [Option a]
standardOptions :: DebugM () -> [Option a] -> [Option a]
standardOptions repaint menu = [
('v',(False,"toggle verbosity", modifyDisplayMode toggleVerbosity >>
repaint >>
......@@ -233,14 +233,14 @@ standardOptions repaint menu = [
interact repaint menu))
]
addToHistory :: Bool -> Char -> Debug a -> Debug a
addToHistory :: Bool -> Char -> DebugM a -> DebugM a
addToHistory False _ a = a
addToHistory True c a = do
st <- get
put st{history=c:history st}
a
getRewindChar :: Debug Char
getRewindChar :: DebugM Char
getRewindChar = do
st <- get
if rewinding st
......@@ -252,10 +252,10 @@ getRewindChar = do
return c
else liftIO getChar
nl :: Debug ()
nl :: DebugM ()
nl = liftIO (putChar '\n')
getDepth :: Debug (Maybe Int)
getDepth :: DebugM (Maybe Int)
getDepth = do
d <- getDisplayMode >>= return . depth
liftIO $ do
......@@ -328,7 +328,7 @@ initState isIO name
bis alle Funktionsaufrufe bewertet sind oder ein Bug
gefunden wurde.
-}
traceProgram :: Debug a -> DebugState -> IO ()
traceProgram :: DebugM a -> DebugState -> IO ()
traceProgram debugloop state = do
bug <- runErrorT $ runStateT debugloop state
report state debugloop bug
......@@ -339,7 +339,7 @@ traceProgram debugloop state = do
darin alle Funktionsaufrufe bewertet sind oder ein
fehlerhafter Aufruf gefunden wurde.
-}
traceLoop :: Debug a -> Debug a
traceLoop :: DebugM a -> DebugM a
traceLoop program
= do state <- get
put $ state { past=emptyBoolStack }
......@@ -364,7 +364,7 @@ traceLoop program
rewind = rewind endState}
traceLoop program
traceWithStepfile :: ShowTerm a => String -> Debug a -> IO ()
traceWithStepfile :: ShowTerm a => String -> DebugM a -> IO ()
traceWithStepfile name program =
initState False name >>=
traceProgram (traceLoop $ traceFunCall (return $ consTerm "main" []) program)
......@@ -374,18 +374,18 @@ runWithStepfile :: ShowTerm a => String -> (IO' a) -> IO ()
runWithStepfile name 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)
-- 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
sx1 <- showTerm f
sx2 <- showTerm x
return (consTerm s [sx1,sx2])) (unprim f x)
-- 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)
......@@ -402,7 +402,7 @@ banner :: IO ()
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
hSetEcho stdin True
case bug of
......@@ -421,22 +421,22 @@ report state debugloop bug = do
showCall :: Debug Term -> Debug ()
showCall :: DebugM Term -> DebugM ()
showCall = printTerm ""
showResult :: ShowTerm a => a -> Debug ()
showResult :: ShowTerm a => a -> DebugM ()
showResult res = printTerm " ~> " (showTerm res)
printTerm :: String -> Debug Term -> Debug ()
printTerm :: String -> DebugM Term -> DebugM ()
printTerm s termAct = do
t <- termAct
liftIO (putStr (s++show t))
withColor :: String -> Debug () -> Debug ()
withColor :: String -> DebugM () -> DebugM ()
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))
-- saved values of external functions and their representation
---------------------------------------------------------------
liftDebug :: Debug () -> Debug ()
liftDebug act = do
liftDebugM :: DebugM () -> DebugM ()
liftDebugM act = do
st <- get
if mainthread st then act else return ()
getGuiHandle :: Debug Handle
getGuiHandle :: DebugM Handle
getGuiHandle = do
st <- get
case gui st of
......@@ -470,13 +470,13 @@ getGuiHandle = do
\values are not available."
put (st{gui=Nothing})
getGuiHandle
closeGui :: Debug ()
closeGui :: DebugM ()
closeGui = putIfAlive 'q'
resetGui :: Debug ()
resetGui :: DebugM ()
resetGui = putIfAlive '!'
putIfAlive :: Char -> Debug ()
putIfAlive :: Char -> DebugM ()
putIfAlive c = do
st <- get
maybe (return ())
......@@ -485,18 +485,18 @@ putIfAlive c = do
(\_ -> return ()))
(gui st)
addConsole :: Char -> Debug ()
addConsole c = liftDebug $ do
addConsole :: Char -> DebugM ()
addConsole c = liftDebugM $ do
h <- getGuiHandle
liftIO $ hPutStr h ['c',c] >> hFlush h
addReadFile, addWrittenFile, addAppendedFile :: String -> String -> Debug ()
addReadFile, addWrittenFile, addAppendedFile :: String -> String -> DebugM ()
addReadFile = addFile 'r'
addWrittenFile = addFile 'w'
addAppendedFile = addFile 'a'
addFile :: Char -> String -> String -> Debug ()
addFile c fn cont = liftDebug $ do
addFile :: Char -> String -> String -> DebugM ()
addFile c fn cont = liftDebugM $ do
h <- getGuiHandle
liftIO $ do
hPutStrLn h (c:fn)
......@@ -510,7 +510,7 @@ split s = case break (=='\n') s of
(n,_:vres) -> let (v,res) = splitAt (read n) vres in
v:split res
getNextExtVal :: Read a => Debug a
getNextExtVal :: Read a => DebugM a
getNextExtVal = do
st <- get
let vals = extValues st
......
src/oracle/stricths.curry
View file @ 7ecfe31c
......@@ -12,7 +12,8 @@ import qualified TransTools as TT
import Char
import Make
import Directory
import ReadShowTerm
import FiniteMap
-------------------------------------
-- constants and naming conventions
......@@ -72,17 +73,15 @@ addFcy = (++".fcy")
main :: IO ()
main = do
(force, mk, stFile, progName) <- parseArgs
transform stFile force mk progName
(force, stFile, progName) <- parseArgs
transform stFile force progName
type Args = (Bool, -- force transformation,
Bool, -- make, i.e., follow import dependencies,
String, -- name of stepfile
String) -- name of module)
isForce s = s=="-f" || s=="--forced"
isMake s = s=="-m" || s=="--make"
mStepFile s = case s of
'-':'s':fn -> Just fn
'-':'-':'s':'t':'e':'p':'f':'i':'l':'e':fn -> Just fn
......@@ -92,29 +91,63 @@ parseArgs :: IO Args
parseArgs = do
args <- getArgs
if (null args)
then error "usage: stricths [-c|--curry] [-f|--force] [-m|--make]\
then error "usage: stricths [-f|--force] \
\[-s<filename>|--stepfile<filename>] <modulename>"
else return (any isForce args,
any isMake args,
maybe (last args) id
(listToMaybe (catMaybes (map mStepFile args))),
last args)
where last xs = xs !! (length xs-1)
transform :: String -> Bool -> Bool -> String -> IO ()
transform stFile _ False progName =
readFlatCurry progName >>= writeTrans stFile "" []
transform stFile force True progName = make progName tester (writeTrans stFile)
transform :: String -> Bool -> String -> IO ()
transform stFile force progName = make progName tester (writeTrans stFile)
where
tester = if force then (\ _ _ -> return (Just ()))
else obsolete targetName [addFcy,incName,trustName]
(const (return ()))
writeTrans :: String -> String -> [()] -> Prog -> IO ()
writeTrans stFile path _ prog = do
tester = if force then (\ _ _ -> return Nothing)
else obsolete targetName [addFcy,incName,trustName] readTypes
readTypes fn = do
prog <- readFile fn
let typeString = dropWhile (/='[') $ dropWhile (/=']') $ dropWhile (/='[') prog
types = fst $ head $ readsTerm typeString
return $ makeConsTable types
type CNames = FM QName QName
ltQName :: QName -> QName -> Bool
ltQName (m1,n1) (m2,n2) = let cm = cmpString m1 m2
in cm==LT || (cm==EQ && cmpString n1 n2==LT)
makeConsTable :: [TypeDecl] -> CNames
makeConsTable ts =
listToFM ltQName $
concatMap (fst . foldr mkConsTab ([],(0,0,0,0,0))) $
map typeConsDecls $
filter (not . isTypeSyn) ts
where
co s = (strictLib,s)
mkConsTab t (ps,(zero,one,two,three,n)) = case consArity t of
0 -> ((consName t,if zero<3 then co $ "C0_"++show zero
else co $ "C0_ "++show zero):ps,
(zero+1,one,two,three,n))
1 -> ((consName t,if one<3 then co $ "C1_"++show one
else co $ "C1_ "++show one):ps,
(zero,one+1,two,three,n))
{-2 -> ((consName t,if two<3 then (co $ "C2_"++show two,id)
else (co "C2_",(Lit (Intc two):))):ps,
(zero,one,two+1,three,n))
3 -> ((consName t,if three<3 then (co $ "C3_"++show three,id)
else (co "C3_",(Lit (Intc three):))):ps,
(zero,one,two,three+1,n))
_ -> ((consName t,(co "C",(Lit (Intc n):))):ps,
(zero,one,two,three,n+1))-}
writeTrans :: String -> String -> [CNames] -> Prog -> IO CNames
writeTrans stFile path names prog = do
let fn = path ++ targetName (progName prog)
inc = path ++ incName (progName prog)
trust = path ++ trustName (progName prog)
nameTable = foldr plusFM (makeConsTable (progTypes prog)) names
print (fmToList nameTable)
ex <- doesFileExist inc
include <- if ex then readFile inc else return ""
ex <- doesFileExist trust
......@@ -122,19 +155,20 @@ writeTrans stFile path _ prog = do
else return Nothing
putStrLn ("generating "++fn)
writeFile fn (showProg include
(transProg stFile (mkTrustData trustInfo) prog))
(transProg stFile (mkTrustData trustInfo) nameTable prog))
return nameTable
----------------------------------
-- the transformation
----------------------------------
transProg :: String -> Trust -> Prog -> Prog
transProg stFile trust prog
transProg :: String -> Trust -> CNames -> Prog -> Prog
transProg stFile trust nameTable prog
= updProg (prefix++)
(((strictLib:) . (impPrelude:) . map (prefix++)))
(concatMap transType)
((concatMap showDecl (progTypes prog)++)
. concatMap (addFtraceCall stFile trust . transFunc))
. concatMap (addFtraceCall stFile trust . transFunc nameTable))
(filter (not . isApplyName . opName))
(updQNamesInProg cleanName prog)
......@@ -150,9 +184,9 @@ transType t
where
(m,n) = typeName t
transFunc :: FuncDecl -> FuncDecl
transFunc func = updFuncType (liftResultType (funcArity func)) $
updFuncBody strictExpr func
transFunc :: CNames -> FuncDecl -> FuncDecl
transFunc names func = updFuncType (liftResultType (funcArity func)) $
updFuncBody (strictExpr names) func
transCons :: ConsDecl -> ConsDecl
transCons (Cons mn a v ts) = Cons mn a v (map liftConsArgs ts)
......@@ -371,24 +405,24 @@ max x y = if x>y then x else y
maxs :: [Int] -> Int
maxs = foldl max 0
strictExpr :: Expr -> Expr