Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
kics
Commits
7ecfe31c
Commit
7ecfe31c
authored
Feb 15, 2008
by
bbr
Browse files
marginal improvements
parent
013a31f0
Changes
4
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
->
Debug
M
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
->
Debug
M
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
->
Debug
M
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
=>
Debug
M
[
Term
]
->
a
->
Debug
M
[
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
::
Debug
M
DisplayMode
getDisplayMode
=
do
state
<-
get
liftIO
$
readIORef
(
displayMode
state
)
modifyDisplayMode
::
(
DisplayMode
->
DisplayMode
)
->
Debug
()
modifyDisplayMode
::
(
DisplayMode
->
DisplayMode
)
->
Debug
M
()
modifyDisplayMode
f
=
do
state
<-
get
liftIO
$
modifyIORef
(
displayMode
state
)
f
---------------------------------------------------------------
-- representation of
ex
ternal data types
-- representation of
in
ternal 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 transit
e
vely
--- if test
was True
.
--- calls act on each imported module transit
i
vely
--- 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
->
Debug
M
()
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
::
Debug
M
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
::
Debug
M
a
->
Debug
M
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
::
Debug
M
()
oneStep
=
eval
(
return
()
)
putCorrect
::
Bool
->
Debug
()
putCorrect
::
Bool
->
Debug
M
()
putCorrect
b
=
do
{
st
<-
get
;
put
st
{
correct
=
b
}}
putSilent
::
Bool
->
Debug
()
putSilent
::
Bool
->
Debug
M
()
putSilent
b
=
do
{
st
<-
get
;
put
st
{
interactive
=
not
b
,
mainthread
=
not
b
}}
evalWith
::
(
Bool
->
Debug
()
)
->
Debug
a
->
Debug
a
evalWith
::
(
Bool
->
Debug
M
()
)
->
Debug
M
a
->
Debug
M
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
=>
Debug
M
Term
->
Debug
M
a
->
Debug
M
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
=>
Debug
M
Term
->
Debug
M
a
->
Debug
M
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
=>
Debug
M
Term
->
Debug
M
a
->
Debug
M
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
,
Debug
M
a
))
right
::
Debug
()
->
Debug
a
->
DebugState
->
Option
a
right
::
Debug
M
()
->
Debug
M
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
=>
Debug
M
()
->
a
->
DebugState
->
Debug
M
Term
->
Debug
M
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
=>
Debug
M
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
=>
Debug
M
Term
->
Debug
M
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
::
Debug
M
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
::
Debug
M
()
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
::
Debug
M
()
->
[
Option
a
]
->
Debug
M
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
::
Debug
M
()
->
[
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
->
Debug
M
a
->
Debug
M
a
addToHistory
False
_
a
=
a
addToHistory
True
c
a
=
do
st
<-
get
put
st
{
history
=
c
:
history
st
}
a
getRewindChar
::
Debug
Char
getRewindChar
::
Debug
M
Char
getRewindChar
=
do
st
<-
get
if
rewinding
st
...
...
@@ -252,10 +252,10 @@ getRewindChar = do
return
c
else
liftIO
getChar
nl
::
Debug
()
nl
::
Debug
M
()
nl
=
liftIO
(
putChar
'
\n
'
)
getDepth
::
Debug
(
Maybe
Int
)
getDepth
::
Debug
M
(
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
::
Debug
M
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
::
Debug
M
a
->
Debug
M
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
->
Debug
M
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
->
Debug
M
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
->
Debug
M
b
))
->
a
->
Debug
M
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
->
Debug
M
b
)
->
a
->
Debug
M
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
->
Debug
M
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
::
Debug
M
Term
->
Debug
M
()
showCall
=
printTerm
""
showResult
::
ShowTerm
a
=>
a
->
Debug
()
showResult
::
ShowTerm
a
=>
a
->
Debug
M
()
showResult
res
=
printTerm
" ~> "
(
showTerm
res
)
printTerm
::
String
->
Debug
Term
->
Debug
()
printTerm
::
String
->
Debug
M
Term
->
Debug
M
()
printTerm
s
termAct
=
do
t
<-
termAct
liftIO
(
putStr
(
s
++
show
t
))
withColor
::
String
->
Debug
()
->
Debug
()
withColor
::
String
->
Debug
M
()
->
Debug
M
()
withColor
c
act
=
liftIO
(
putStr
c
)
>>
act
>>
liftIO
(
putStr
off
)
type
IO'
a
=
Debug
(
Prim
(
World
->
Debug
a
))
type
IO'
a
=
Debug
M
(
Prim
(
World
->
Debug
M
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
liftDebug
M
::
Debug
M
()
->
Debug
M
()
liftDebug
M
act
=
do
st
<-
get
if
mainthread
st
then
act
else
return
()
getGuiHandle
::
Debug
Handle
getGuiHandle
::
Debug
M
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
::
Debug
M
()
closeGui
=
putIfAlive
'q'
resetGui
::
Debug
()
resetGui
::
Debug
M
()
resetGui
=
putIfAlive
'!'
putIfAlive
::
Char
->
Debug
()
putIfAlive
::
Char
->
Debug
M
()
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
->
Debug
M
()
addConsole
c
=
liftDebug
M
$
do
h
<-
getGuiHandle
liftIO
$
hPutStr
h
[
'c'
,
c
]
>>
hFlush
h
addReadFile
,
addWrittenFile
,
addAppendedFile
::
String
->
String
->
Debug
()
addReadFile
,
addWrittenFile
,
addAppendedFile
::
String
->
String
->
Debug
M
()
addReadFile
=
addFile
'r'
addWrittenFile
=
addFile
'w'
addAppendedFile
=
addFile
'a'
addFile
::
Char
->
String
->
String
->
Debug
()
addFile
c
fn
cont
=
liftDebug
$
do
addFile
::
Char
->
String
->
String
->
Debug
M
()
addFile
c
fn
cont
=
liftDebug
M
$
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
=>
Debug
M
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