Commit 9deedfc1 authored by Vincent Zweije's avatar Vincent Zweije
Browse files

This commit was generated by cvs2svn to compensate for changes in r686,

which included commits to RCS files with non-trunk default branches.
parent bf198574
......@@ -15,6 +15,7 @@ Basic types and functions.
*/
from general import Optional
from StdFile import <<<
import StdOverloaded
import StdString
......@@ -72,6 +73,9 @@ foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) |
// Foldoptional is the standard fold for the optional type.
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
// Force evaluation of first argument to root normal form before returning second
force :: !.a .b -> .b
// Forget drops a mapped value from a map given by a list.
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
......@@ -97,6 +101,12 @@ join :: a ![.[a]] -> .[a]
*/
kleene :: !.[symbol] -> .[[symbol]]
// Lazy variant of the predefined abort function
error :: .String -> .a
// Determine the string representation of a list
listToString :: [a] -> String | toString a
// Lookup finds a value mapped in a list mapping.
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
......@@ -130,6 +140,9 @@ maptl :: .(x:[.a] -> u:[.a]) !w:[.a] -> v:[.a], [u <= v, w <= x]
// Map three functions onto a triple.
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
// String representation of line terminator
nl :: String
// Pairwith pairs a value with its result under a given function
pairwith :: .(arg -> .res) arg -> (arg,.res)
......@@ -156,12 +169,18 @@ relimg :: ![(a,.b)] a -> [.b] | == a
// `Remap x y mapping' alters the mapping by associating y with x, removing the old values.
remap :: a b [.(a,b)] -> .[(a,b)] | == a
// A variant of foldl that is strict in its accumulator
sfoldl :: (.a -> .(.b -> .a)) !.a [.b] -> .a
// `Shorter xs' determines whether a list is shorter than list `xs'.
shorter :: ![.a] [.b] -> .Bool
// `Showbool b' is the string representation of boolean `b'.
showbool :: .(!.Bool -> a) | fromBool a
// Determine a string representation of a list
showlist :: (.elem -> .String) ![.elem] -> String
// `Showoptional showa opt' is the string representation of optional value `opt',
// where `showa' determines the string representation of the inner value.
showoptional :: .(.a -> .String) !(Optional .a) -> String
......@@ -187,3 +206,9 @@ superset :: .[a] -> .(.[a] -> Bool) | == a
// zipwith zips up two lists with a joining function
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
// Strict version of --->, which evaluates its lhs first
(<---) infix :: !.a !b -> .a | <<< b
// Sequential evaluation of left and right arguments
($) infixr :: !.a .b -> .b
......@@ -25,7 +25,7 @@ Implementation
//:: Optional t = Absent | Present t
// Now using Optional type from cocl's general module
from general import Optional,No,Yes
from general import Optional,No,Yes,--->
instance == (Optional a) | == a
where (==) No No = True
......@@ -56,15 +56,16 @@ results recursively, and so on. Duplicates are removed. */
depthfirst :: (res->.[elem]) (elem->res) !.[elem] -> .[res] | == elem
depthfirst generate process xs
= snd (collect xs ([],[]))
where collect [] seenrest = seenrest
collect [x:xs] (seen,rest)
= snd (collect xs ([],[]))
where collect [] seenrest = seenrest
collect [x:xs] seenrest
| isMember x seen
= collect xs (seen,rest)
= (seen``,[y:rest``])
where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
(seen``,rest`) = collect xs ( seen`,rest)
y = process x
= collect xs seenrest
= (seen``,[y:rest``])
where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
(seen``,rest`) = collect xs ( seen`,rest)
y = process x
(seen,rest) = seenrest
// `Disjoint xs ys' checks whether xs and ys are disjoint.
......@@ -89,22 +90,28 @@ foldlm f (l,[m:ms])
(l``,ms`) = foldlm f (l`,ms)
foldlr :: (.elem -> .((.lrinfo,.rlinfo) -> (.lrinfo,.rlinfo))) !(.lrinfo,.rlinfo) ![.elem] -> (.lrinfo,.rlinfo)
foldlr f (l,r) []
= (l,r)
foldlr f (l,r) [x:xs]
foldlr f lr []
= lr
foldlr f lr [x:xs]
= (l``,r``)
where (l``,r`) = foldlr f (l`,r) xs
(l`,r``) = f x (l,r`)
(l,r) = lr
foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) | == arg, [v u <= w, v <= x]
foldmap f d
= foldr foldmap` (const d)
where foldmap` (x,y) g v = if (x==v) (f y) (g v)
= foldr foldmap` (const d)
where foldmap` xy g v
= if (x==v) (f y) (g v)
where (x,y) = xy
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
foldoptional no yes No = no
foldoptional no yes (Yes x) = yes x
force :: !.a .b -> .b
force x y = y
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
forget x = filter (neq x o fst)
neq x y = x <> y
......@@ -159,6 +166,14 @@ kleene symbols
= flatten (map appendstrings symbols)
where appendstrings symbol = map (cons symbol) strings
// Lazy variant of the predefined abort function
error :: .String -> .a
error message = abort message
// Determine the string representation of a list
listToString :: [a] -> String | toString a
listToString xs = showlist toString xs
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
lookup = foldmap id (abort "lookup: not found")
......@@ -211,6 +226,10 @@ maptl f [x:xs] = [x:f xs]
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
maptriple f g h = app3 (f,g,h)
// String representation of line terminator
nl :: String
nl =: "\n"
partition :: (a -> b) (a -> .c) -> .(!.[a] -> [(b,[.c])]) | == b
partition f g
= h
......@@ -227,6 +246,14 @@ relimg rel x` = [y\\(x,y)<-rel|x==x`]
remap :: a b [.(a,b)] -> .[(a,b)] | == a
remap x y xys = [(x,y):forget x xys]
// A variant of foldl that is strict in its accumulator
sfoldl :: (.a -> .(.b -> .a)) !.a [.b] -> .a
sfoldl f a xxs
#! a = a
= case xxs
of [] -> a
[x:xs] -> sfoldl f (f a x) xs
shorter :: ![.a] [.b] -> .Bool
shorter [] yys = False
shorter [x:xs] [] = True
......@@ -235,6 +262,14 @@ shorter [x:xs] [y:ys] = shorter xs ys
showbool :: .(!.Bool -> a) | fromBool a
showbool = fromBool
showlist :: (.elem -> .String) ![.elem] -> String
showlist showa xs
= "["+++inner xs+++"]"
where inner [] = ""
inner [x:xs] = showa x+++continue xs
continue [] = ""
continue [x:xs] = ","+++showa x+++continue xs
showoptional :: .(.a -> .String) !(Optional .a) -> String
showoptional showa No = "No"
showoptional showa (Yes a) = "(Yes "+++showa a+++")"
......@@ -268,3 +303,15 @@ superset set = isEmpty o (removeMembers set)
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
// Strict version of --->, which evaluates its lhs first
(<---) infix :: !.a !b -> .a | <<< b
(<---) value message = value ---> message
($) infixr :: !.a .b -> .b
($) x y = y
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
= file <<< x writeList xs
......@@ -5,6 +5,7 @@ implementation module canon
import rule
import graph
import basic
import general
import StdEnv
/*
......@@ -60,7 +61,7 @@ steps:
canonise :: (sym -> Rule tsym tvar) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise typerule heap rg
= (relabel heap o etaexpand typerule o splitrg o relabel localheap) rg
= ((relabel heap o etaexpand typerule o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
/*
......@@ -113,9 +114,10 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label rgraph
= (label rgraph,foldsingleton single nosingle rgraph)
= ((id (labelrgraph,foldsingleton single nosingle rgraph)) <--- "canon.foldarea ends") ---> "canon.foldarea begins"
where single root sym args = args
nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph])
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
------------------------------------------------------------------------
......@@ -139,13 +141,13 @@ foldarea label rgraph
labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea areas labels rg
= foldmap id nolabel (maketable areas labels) rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
where nolabel = abort "canon: labelarea: no label assigned to area"
maketable :: [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable [] _ = []
maketable [] _ = [] <--- "canon.maketable ends empty"
maketable [area:areas] labels
= [(area,label):maketable areas labels`]
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") areas labels`] <--- "canon.maketable ends nonempty"
where (label,labels`) = getlabel (nc aroot) labels
getlabel (True,(asym,aargs)) labels
| not (or (map (fst o nc) aargs))
......
......@@ -3,6 +3,7 @@ implementation module complete
// $Id$
import graph
import basic
import StdEnv
/*
......@@ -78,10 +79,11 @@ coveredby complete subject pvarss [svar:svars]
| complete (map fst3 closeds)
= and (map covered closeds)
= coveredby complete subject opens svars
where (opens,closeds) = split pvarss
covered (sym,repvar`,pvarss`) = coveredby complete subject pvarss` (repvar (repvar` undef) svar++svars)
where (opens,closeds) = psplit pvarss
covered (sym,repvar`,pvarss`) = coveredby complete subject pvarss` (repvar (repvar` dummyvar) svar++svars)
(sdef,(ssym,sargs)) = varcontents subject svar
tmpvalue = (fst (foldr (spl (repvar sargs) ssym) ([],[]) pvarss))
dummyvar = abort "complete: error: accessing dummy variable"
repvar pvars svar = map (const svar) pvars
......@@ -94,7 +96,7 @@ multipatterns with an open pattern are expanded and added as well.
*/
split
psplit
:: [Pattern sym var]
-> ( [Pattern sym var]
, [ ( sym
......@@ -106,14 +108,14 @@ split
| == sym
& == var
split [] = ([],[])
split [(subject,[svar:svars]):svarss]
psplit [] = ([],[])
psplit [(subject,[svar:svars]):svarss]
| not sdef
= ([(subject,svars):opens`],map add closeds`)
= (opens,[(ssym,repvar,[(subject,sargs++svars):ins]):closeds])
where (opens`,closeds`) = split svarss
where (opens`,closeds`) = psplit svarss
add (sym,repvar,svarss`) = (sym,repvar,[(subject,repvar svar++svars):svarss`])
(opens,closeds) = split outs
(opens,closeds) = psplit outs
(ins,outs) = foldr (spl repvar ssym) ([],[]) svarss
repvar svar = map (const svar) sargs
(sdef,(ssym,sargs)) = varcontents subject svar
......
......@@ -3,6 +3,7 @@ implementation module dnc
// $Id$
import graph
import basic
import StdEnv
// dnc is like varcontents, but can give a more reasonable error message
......
......@@ -4,6 +4,7 @@ definition module graph
from pfun import Pfun
from StdOverloaded import ==
from StdString import String,toString
// A rule associating a replacement with a pattern
//:: Rule sym var
......@@ -139,6 +140,9 @@ varlist :: .(Graph sym var) !.[var] -> .[var] | == var
// Cannot remember what this one does???
prefix :: .(Graph sym var) .[var] !.[var] -> .([var],[var]) | == var
// Determine a multiline representation of a graph with multiple roots
printgraph :: .(Graph sym var) .[var] -> .[String] | toString sym & toString var & == var
// Do reference counting in a graph for the outer bindings.
// References from case branches are counted once only.
// Initial list of variables is counted too.
......
......@@ -4,6 +4,7 @@ implementation module graph
import pfun
import basic
import general
import StdEnv
/*
......@@ -157,7 +158,30 @@ prefix graph without vars
> = (seen1,'(':showfunc func++concat (map (' ':) repr1)++")"), otherwise
> (seen1,repr1) = foldlr pg (node:seen,[]) args
> (def,(func,args)) = nodecontents graph node
*/
printgraph :: .(Graph sym var) .[var] -> .[String] | toString sym & toString var & == var
printgraph graph nodes
= prntgrph (refcount graph nodes) graph nodes
prntgrph count graph nodes
= snd (foldlr pg ([],[]) nodes)
where pg node (seen,reprs)
= (seen2,[repr3:reprs])
where repr3
= if (not (isMember node seen) && def && count node>1)
(toString node+++":"+++repr2)
repr2
(seen2,repr2)
= if (isMember node seen || not def)
(seen,toString node)
(if (args==[])
(seen1,toString func)
(seen1,"("+++toString func+++foldr (+++) ")" (map ((+++)" ") repr1)))
(seen1,repr1) = foldlr pg ([node:seen],[]) args
(def,(func,args)) = varcontents graph node
/*
> refcount graph
> = foldr rfcnt (const 0)
> where rfcnt node count
......@@ -396,5 +420,5 @@ mapgraph ::
mapgraph f (GraphAlias pfun) = GraphAlias (f pfun)
instance == (Graph sym var) | == sym & == var
where (==) pf1 pf2
= pf1 == pf2
where (==) (GraphAlias pf1) (GraphAlias pf2)
= ((pf1 == pf2) <--- "graph.==(Graph) ends") ---> "graph.==(Graph) begins"
......@@ -6,6 +6,7 @@ from rule import Rgraph
from graph import Graph
from general import Optional
from StdOverloaded import ==
from StdString import toString
// A history relates node-ids in the subject graph to patterns
:: History sym var
......@@ -35,3 +36,6 @@ matchhistory
-> [HistoryPattern sym var] // Matching history patterns
| == sym
& == var
(writeHistory) infixl :: *File (History sym var) -> .File | toString sym & toString,== var
(writeHistoryAssociation) infixl :: *File (HistoryAssociation sym var) -> .File | toString sym & toString,== var
......@@ -59,3 +59,9 @@ instantiate ::
([(pvar,var)],[(pvar,var)],[(pvar,var)])
-> ([(pvar,var)],[(pvar,var)],[(pvar,var)])
*/
(writeHistory) infixl :: *File (History sym var) -> .File | toString sym & toString,== var
(writeHistory) file history = sfoldl (writeHistoryAssociation) file history
(writeHistoryAssociation) infixl :: *File (HistoryAssociation sym var) -> .File | toString sym & toString,== var
(writeHistoryAssociation) file ha = file <<< showpair toString (showlist toString) ha <<< nl
......@@ -11,7 +11,7 @@ import rule
import graph
import pfun
import basic
from general import Yes,No
from general import Yes,No,--->
import StdEnv
/*
......@@ -341,8 +341,8 @@ startswith _ _ = False
// ==== ATTEMPT TO UNFOLD A REWRITE RULE ====
tryunfold
:: var // The root of the redex
tryunfold ::
var // The root of the redex
(Rule sym pvar) // The rule to unfold
(Pfun pvar var) // The matching from rule's pattern to subject
(Spine sym var pvar) // The spine returned by the strategy
......
......@@ -11,6 +11,8 @@ import graph
import basic
import StdEnv
import general
/*
newfold.lit - New folding function
......@@ -110,9 +112,9 @@ fullfold ::
& == pvar
fullfold trc foldarea fnsymbol trace
| recursive
= addlhs recurseresult
= addlhs (newextract trc foldarea trace)
| recursive ---> "newfold.fullfold begins"
= addlhs recurseresult <--- "newfold.fullfold ends (recursive=True)"
= addlhs (newextract trc foldarea trace) <--- "newfold.fullfold ends (recursive=False)"
where (recursive,recurseresult) = recurse foldarea fnsymbol trace
addlhs = mapsnd3 (pair (arguments rule))
(Trace _ rule _ _ _) = trace
......@@ -137,25 +139,28 @@ recurse ::
& == pvar
recurse foldarea fnsymbol
= f ([],[])
where f (newhist,hist) (Trace stricts rule answer history (Reduce reductroot trace))
= (f ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
where f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,newhist`) trace
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
f (newhist,hist) (Trace stricts rule answer history (Annotate trace))
(newhist,hist) = newhisthist
f newhisthist (Trace stricts rule answer history (Annotate trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,hist) trace
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
f (newhist,hist) (Trace stricts rule answer history transf)
(newhist,hist) = newhisthist
f newhisthist (Trace stricts rule answer history transf)
= foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf)
where rroot = ruleroot rule; rgraph = rulegraph rule
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
/*
......@@ -252,24 +257,25 @@ newextract ::
& == pvar
newextract trc newname (Trace stricts rule answer history transf)
| recursive
= (stricts,rule2body recrule,recareas)
| recursive ---> "newfold.newextract begins"
= (stricts,rule2body recrule,recareas) <--- "newfold.newextract ends (recursive=True)"
= case transf
of Reduce reductroot trace
-> newextract trc newname trace
-> newextract trc newname trace <--- "newfold.newextract ends (at Reduce transformation)"
Annotate trace
-> newextract trc newname trace
-> newextract trc newname trace <--- "newfold.newextract ends (at Annotate transformation)"
Instantiate yestrace notrace
-> (stricts,matchpattern answer yesbody nobody,yesareas++noareas)
-> (stricts,matchpattern answer yesbody nobody,yesareas++noareas) <--- "newfold.newextract ends (at Instantiate transformation)"
where (_,yesbody,yesareas) = newextract trc newname yestrace
(_,nobody,noareas) = newextract trc newname notrace
Stop
-> (stricts,buildgraph rargs rroot stoprgraph,stopareas)
-> (stricts,buildgraph rargs rroot stoprgraph,stopareas) <--- "newfold.newextract ends (at Stop transformation)"
where (recursive,unsafearea)
= if (isreduce transf)
(foldoptional (False,undef) (findspinepart rule transf) answer)
(foldoptional (False,dummycontents) (findspinepart rule transf) answer)
(False,abort "newextract: not a Reduce transformation")
dummycontents = abort "newfold: newextract: accessing dummy node contents"
(recrule,recareas) = splitrule newname rnfnodes deltanodes rule unsafearea
(stoprgraph,stopareas) = finishfold newname rnfnodes deltanodes rroot rgraph
......@@ -283,8 +289,12 @@ buildgraph ::
[var]
var
(Graph sym var)
-> FuncBody sym var
buildgraph _ _ _ = undef
-> FuncBody sym var | == var
buildgraph args root graph
= (BuildGraph (mkrgraph root (compilegraph (map (pairwith (snd o varcontents graph)) newnodes))) <--- "newfold.buildgraph ends") ---> "newfold.buildgraph begins"
where newnodes = removeMembers closedreplnodes patnodes
closedreplnodes = fst (graphvars graph [root])
patnodes = varlist graph args
isreduce (Reduce reductroot trace) = True
isreduce transf = False
......@@ -313,7 +323,9 @@ findspinepart rule transf spine
= (True,mkrgraph node pattern`)
= recursion
force _ res = res
partial rule matching _ (pattern,recursion) = (extgraph` graph rule matching pattern,recursion)
partial rule matching _ pr
= (extgraph` graph rule matching pattern,recursion)
where (pattern,recursion) = pr
redex rule matching = (extgraph` graph rule matching emptygraph,norecursion)
stop = (emptygraph,norecursion)
norecursion = (False,abort "findspinepart: no part of spine found")
......@@ -381,3 +393,13 @@ getdeltanodes spine
force _ nodes = (True,nodes)
partial _ _ _ nodes = (False,nodes)
redex _ _ = none
instance <<< FuncBody sym var | toString sym & ==,toString var
where (<<<) file (MatchPattern pat yesbody nobody)
= file <<< "?Match: " <<< pat <<< nl
<<< "Match succes:" <<< nl
<<< yesbody
<<< "Match failure:" <<< nl
<<< nobody
(<<<) file (BuildGraph rgraph)
= file <<< "Build: " <<< toString rgraph <<< nl
......@@ -13,6 +13,7 @@ import rule
import graph
import canon
import basic
import general
import StdEnv
/*
......@@ -157,6 +158,32 @@ these tuples.
, srr_areas :: [Rgraph sym var] // New areas for further symbolic reduction (not necessarily canonical)
}
instance toString Symredresult sym var tsym tvar | toString sym & toString var & == var
where toString srr
= "Task: "+++toString srr.srr_task_expression+++
"\nSymbol: "+++toString srr.srr_assigned_symbol+++
"\nStrictness: "+++listToString srr.srr_strictness+++
"\nTyperule: "+++"<typerule>"+++
"\nTrace: "+++"<trace>"+++
"\nFunction definition: "+++"<funcdef>"+++
"\nAreas: "+++listToString srr.srr_areas+++"\n"
instance <<< Symredresult sym var tsym tvar | toString sym & <<<,==,toString var
where (<<<) file srr
= file <<< "==[BEGIN]==" <<< nl
<<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl
<<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
<<< "Strictness: " <<< srr.srr_strictness <<< nl
<<< "Type rule: ..." <<< nl
<<< srr.srr_trace <<< nl