aboutsummaryrefslogtreecommitdiff
path: root/sucl
diff options
context:
space:
mode:
Diffstat (limited to 'sucl')
-rw-r--r--sucl/basic.icl2
-rw-r--r--sucl/canon.icl6
-rw-r--r--sucl/cli.icl22
-rw-r--r--sucl/graph.icl16
-rw-r--r--sucl/loop.dcl5
-rw-r--r--sucl/loop.icl11
-rw-r--r--sucl/newfold.icl59
-rw-r--r--sucl/newtest.icl7
8 files changed, 78 insertions, 50 deletions
diff --git a/sucl/basic.icl b/sucl/basic.icl
index bd01b2a..aa90104 100644
--- a/sucl/basic.icl
+++ b/sucl/basic.icl
@@ -314,4 +314,4 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
-= file <<< x writeList xs
+= file <<< x <<< nl writeList xs
diff --git a/sucl/canon.icl b/sucl/canon.icl
index 95b57a3..cf87b70 100644
--- a/sucl/canon.icl
+++ b/sucl/canon.icl
@@ -114,9 +114,9 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label 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<---"canon.foldarea.labelrgraph begins")--->"canon.foldarea.labelrgraph ends",(foldsingleton single nosingle rgraph<---"canon.foldarea.foldsingleton ends")--->"canon.foldarea.foldsingleton begins") <--- "canon.foldarea ends") ---> "canon.foldarea begins"
+ where single root sym args = map (\arg->(arg<---"newfold.foldarea.single.arg begins")--->"newfold.foldarea.single.arg ends") args
+ nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg begins")--->"newfold.foldarea.nosingle.arg ends") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
diff --git a/sucl/cli.icl b/sucl/cli.icl
index a992b00..faa1a4b 100644
--- a/sucl/cli.icl
+++ b/sucl/cli.icl
@@ -105,7 +105,7 @@ Abstype implementation.
> stripexports :: [char] -> cli -> cli
*/
-:: Cli :== Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
+:: Cli = CliAlias (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable)
/*
> cli == module symbol node typesymbol typenode
@@ -121,14 +121,14 @@ Abstype implementation.
*/
exports :: Cli -> [SuclSymbol]
-exports m = m.exportedsymbols
+exports (CliAlias m) = m.exportedsymbols
/*
> typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
-typerule m sym
+typerule (CliAlias m) sym
= maxtyperule m.typerules sym
/*
@@ -153,7 +153,7 @@ typerule m sym
*/
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
-clistrategy {arities=as,typeconstructors=tcs,typerules=ts,rules=rs} matchable
+clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable
= ( checkarity (extendfn as (typearity o maxtyperule ts)) // Checks curried occurrences and strict arguments
o checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...)
o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
@@ -182,7 +182,7 @@ maxstricts defs sym = extendfn defs corestricts sym
*/
complete :: Cli -> [SuclSymbol] -> Bool
-complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
+complete (CliAlias m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/*
> showcli = printcli
@@ -326,10 +326,20 @@ mkcli ::
-> Cli
mkcli typerules stricts exports constrs bodies
-= { arities = map (mapsnd fst) bodies
+= CliAlias
+ { arities = map (mapsnd fst) bodies
, typeconstructors = constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, rules = map (mapsnd snd) bodies
}
+
+instance <<< Cli
+where (<<<) file (CliAlias m)
+ = file <<< "=== Arities ===" <<< nl
+ writeList m.arities
+ <<< "=== Type Rules ===" <<< nl
+ writeList m.typerules
+ <<< "=== Rules ===" <<< nl
+ writeList m.rules
diff --git a/sucl/graph.icl b/sucl/graph.icl
index 02362f1..2021826 100644
--- a/sucl/graph.icl
+++ b/sucl/graph.icl
@@ -97,20 +97,20 @@ varcontents (GraphAlias pfun) v
graphvars :: .(Graph sym var) !.[var] -> (.[var],.[var]) | == var
graphvars graph roots
-= graphvars` [] graph roots
+= (graphvars` [] graph roots<---"graph.graphvars ends")--->"graph.graphvars begins"
// Finds bound and free variables in a graph
// Excludes the variables only reachable through "prune"
graphvars` :: .[var] .(Graph sym var) .[var] -> (.[var],.[var]) | == var
graphvars` prune graph roots
-= snd (foldlr ns (prune,([],[])) roots)
- where ns var (seen,boundfree=:(bound,free))
- | isMember var seen = (seen,boundfree)
- | not def = ([var:seen],(bound,[var:free]))
- = (seen`,([var:bound`],free`))
- where (seen`,(bound`,free`)) = foldlr ns ([var:seen],boundfree) args
+= (snd (foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`") (prune,([],[])) roots)<---"graph.graphvars` ends")--->"graph.graphvars` begins"
+ where ns var seenboundfree
+ | isMember var seen = seenboundfree<---"graph.graphvars`.ns ends (already seen)"
+ | not def = ([var:seen],(bound,[var:free]))<---"graph.graphvars`.ns ends (open variable)"
+ = (seen`,([var:bound`],free`))<---"graph.graphvars`.ns ends (closed variable)"
+ where (seen`,(bound`,free`)) = foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`.ns") ([var:seen],boundfree) args
(def,(_,args)) = varcontents graph var
-
+ (seen,boundfree=:(bound,free)) = seenboundfree
varlist :: .(Graph sym var) !.[var] -> .[var] | == var
varlist graph roots
= depthfirst arguments id roots
diff --git a/sucl/loop.dcl b/sucl/loop.dcl
index d49c0d4..cdc6fc1 100644
--- a/sucl/loop.dcl
+++ b/sucl/loop.dcl
@@ -9,6 +9,8 @@ from history import HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from graph import Graph
from StdOverloaded import ==
+from StdFile import <<<
+from StdString import toString
from strat import Substrategy,Subspine // for Strategy
from trace import History,Transformation // for Trace
@@ -24,6 +26,9 @@ loop
| == sym
& == var
& == pvar
+ & toString sym // Debugging
+ & toString var // Debugging
+ & <<< var // Debugging
initrule
:: ![var]
diff --git a/sucl/loop.icl b/sucl/loop.icl
index f8674c3..50b6021 100644
--- a/sucl/loop.icl
+++ b/sucl/loop.icl
@@ -11,7 +11,7 @@ import rule
import graph
import pfun
import basic
-from general import Yes,No,--->
+from general import Yes,No
import StdEnv
/*
@@ -224,11 +224,14 @@ loop
| == sym
& == var
& == pvar
+ & toString sym // Debugging
+ & toString var // Debugging
+ & <<< var // Debugging
loop strategy matchable (initheap,rule)
-= maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
-
- where maketrace history failinfo instdone stricts sroot subject heap
+= result
+ where result = maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
+ maketrace history failinfo instdone stricts sroot subject heap
= Trace stricts (mkrule sargs sroot subject) answer history transf
where answer = makernfstrategy history (strategy matchable`) rnfnodes sroot subject
transf = transform sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
diff --git a/sucl/newfold.icl b/sucl/newfold.icl
index a654f5a..a9b9f48 100644
--- a/sucl/newfold.icl
+++ b/sucl/newfold.icl
@@ -110,6 +110,9 @@ fullfold ::
| == sym
& == var
& == pvar
+ & toString var
+ & <<< var
+ & toString sym
fullfold trc foldarea fnsymbol trace
| recursive ---> "newfold.fullfold begins"
@@ -137,30 +140,36 @@ recurse ::
| == sym
& == var
& == pvar
+ & toString var
+ & <<< var
+ & toString sym
recurse foldarea fnsymbol
-= (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
+= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
+ where f newhisthist trace
+ | (trace--->trace) $ False
+ = error "shouldn't happen"
+ f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
+ | (isEmpty (pclosed--->"pclosed for isEmpty")--->"f: Reduce: isEmpty?") && (superset (popen--->"popen for superset") (ropen--->"ropen for superset")--->"f: Reduce: superset?")
+ = ((f--->"newfold.recurse.f begins (from Reduce)") (newhist`,newhist`) trace <--- "newfold.recurse.f ends (valid Reduce)") ---> "f: Reduce"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
- (pclosed,popen) = graphvars rgraph rargs
- (_,ropen) = graphvars rgraph [rroot]
- newhist` = [(rroot,rgraph):newhist]
- (newhist,hist) = newhisthist
+ (pclosed,popen) = graphvars (rgraph--->"rgraph for (pclosed,popen)") (rargs--->"rargs for (pclosed,popen)") ---> "get (pclosed,popen)"
+ (_,ropen) = graphvars (rgraph--->"rgraph for ropen") [rroot--->"rroot for ropen"] ---> "get ropen"
+ newhist` = [(rroot,rgraph):newhist--->"newhist"]
+ (newhist,hist) = newhisthist ---> "get (newhist,hist)"
f newhisthist (Trace stricts rule answer history (Annotate trace))
| isEmpty pclosed && superset popen ropen
- = f (newhist`,hist) trace
+ = ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
- (pclosed,popen) = graphvars rgraph rargs
- (_,ropen) = graphvars rgraph [rroot]
+ (pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)"
+ (_,ropen) = graphvars rgraph [rroot] ---> "get ropen"
newhist` = [(rroot,rgraph):newhist]
- (newhist,hist) = newhisthist
+ (newhist,hist) = newhisthist ---> "get (newhist,hist)"
f newhisthist (Trace stricts rule answer history transf)
- = foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf)
+ = ((foldtips--->"newfold.foldtips begins from newfold.recurse") foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) <--- "newfold.recurse.f ends (other transformation)") ---> "f: default"
where rroot = ruleroot rule; rgraph = rulegraph rule
newhist` = [(rroot,rgraph):newhist]
- (newhist,hist) = newhisthist
+ (newhist,hist) = newhisthist ---> "get (newhist,hist)"
/*
@@ -182,26 +191,26 @@ foldtips ::
& == pvar
foldtips foldarea foldcont
-= ft
+= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends"
where ft hist trace
= case transf
of Stop
- -> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule)
+ -> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)"
where deltanodes = foldoptional [] getdeltanodes answer
rnfnodes = foldoptional [ruleroot rule] (const []) answer
Instantiate yestrace notrace
- -> ft` (ft hist yestrace) (ft hist notrace)
- where ft` (False,yessra) (False,nosra) = exres
+ -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.match") hist yestrace) ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.fail") hist notrace)
+ where ft` (False,yessra) (False,nosra) = exres <--- "newfold.foldtips.ft ends (Instantiate/no)"
ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
- = (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas))
+ = (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)"
Reduce reductroot trace
- -> ft` (ft (fst hist,fst hist) trace)
- where ft` (False,sra) = exres
- ft` (found,sra) = (True,sra)
+ -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Reduce") (fst hist,fst hist) trace)
+ where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Reduce/no)"
+ ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)"
Annotate trace
- -> ft` (ft hist trace)
- where ft` (False,sra) = exres
- ft` (found,sra) = (True,sra)
+ -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Annotate") hist trace)
+ where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Annotate/no)"
+ ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)"
where (Trace stricts rule answer _ transf) = trace
exres = (False,newextract noetrc foldarea trace)
diff --git a/sucl/newtest.icl b/sucl/newtest.icl
index d9a7087..13fe716 100644
--- a/sucl/newtest.icl
+++ b/sucl/newtest.icl
@@ -174,9 +174,10 @@ where (<<<) file srr
<<< "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
+ //<<< "Type rule: ..." <<< nl
<<< srr.srr_trace <<< nl
- //<<< "Function definition: ..." <<< nl
+ //<<< "Function definition:" <<< nl
+ //<<< srr.srr_function_def
<<< "Areas:" <<< nl
writeareas srr.srr_areas
<<< "==[END]==" <<< nl
@@ -307,7 +308,7 @@ fullsymred freshsymbols cli
generate result = (map canonise` (getareas result) <--- "newtest.fullsymred.generate begins") ---> "newtest.fullsymred.generate begins"
process area = (symredarea foldarea` cli area <--- "newtest.fullsymred.process ends") ---> "newtest.fullsymred.process begins"
- foldarea` = ((id (foldarea (labelarea` o canonise`))) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
+ foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
labelarea` = (labelarea (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins"
canonise` = (canonise (typerule cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins"
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 13:39:48 +0000