diff options
Diffstat (limited to 'sucl/newtest.icl')
| -rw-r--r-- | sucl/newtest.icl | 63 |
1 files changed, 46 insertions, 17 deletions
diff --git a/sucl/newtest.icl b/sucl/newtest.icl index 688cb08..d9a7087 100644 --- a/sucl/newtest.icl +++ b/sucl/newtest.icl @@ -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 + //<<< "Function definition: ..." <<< nl + <<< "Areas:" <<< nl + writeareas srr.srr_areas + <<< "==[END]==" <<< nl + +(writeareas) infixl :: *File [Rgraph sym var] -> .File | toString sym & toString,== var +(writeareas) file xs = sfoldl (<<<) file xs + /* > listopt :: [char] -> [[char]] -> [char] @@ -276,13 +303,13 @@ fullsymred :: fullsymred freshsymbols cli = results - where results = depthfirst generate process (initareas cli) - generate result = map canonise` (getareas result) - process area = symredarea foldarea` cli area + where results = (depthfirst generate process (initareas cli) <--- "newtest.fullsymred.results ends") ---> "newtest.fullsymred.results begins" + 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` = foldarea (labelarea` o canonise`) - labelarea` = labelarea (map getinit results) freshsymbols - canonise` = canonise (typerule cli) suclheap + foldarea` = ((id (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" /* `Initareas cli' is the list of initial rooted graphs that must be @@ -315,10 +342,12 @@ initareas cli targs = arguments (typerule cli symbol) getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var -getinit srr = srr.srr_task_expression +getinit srr += (srr.srr_task_expression <--- "newtest.getinit ends") ---> "newtest.getinit begins" getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var] -getareas srr = srr.srr_areas +getareas srr += (srr.srr_areas <--- "newtest.getareas ends") ---> "newtest.getareas begins" /* `Symredarea' is the function that does symbolic reduction of a single @@ -352,20 +381,20 @@ symredarea :: -> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable symredarea foldarea cli area -= { srr_task_expression = area - , srr_assigned_symbol = symbol - , srr_strictness = stricts += { srr_task_expression = (area <--- "newtest.symredarea.srr_task_expression ends") ---> "newtest.symredarea.srr_task_expression begins" + , srr_assigned_symbol = (symbol <--- "newtest.symredarea.srr_assigned_symbol ends") ---> "newtest.symredarea.srr_assigned_symbol begins" + , srr_strictness = (stricts <--- "newtest.symredarea.srr_strictness ends") ---> "newtest.symredarea.srr_strictness begins" , srr_typerule = trule - , srr_trace = trace - , srr_function_def = rules - , srr_areas = areas + , srr_trace = (trace <--- "newtest.symredarea.srr_trace ends") ---> "newtest.symredarea.srr_trace begins" + , srr_function_def = (rules <--- "newtest.symredarea.srr_function_def ends") ---> "newtest.symredarea.srr_function_def begins" + , srr_areas = (areas <--- "newtest.symredarea.srr_areas ends") ---> "newtest.symredarea.srr_areas begins" } where agraph = rgraphgraph area; aroot = rgraphroot area (symbol,aargs) = foldarea area arule = mkrule aargs aroot agraph - trule = ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule - trace = loop strategy` matchable` (removeMembers suclheap (varlist agraph [aroot]),arule) - (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace + trule = (ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule <--- "newtest.symredarea.trule.ruletype ends") ---> "newtest.symredarea.trule.ruletype begins" + trace = (loop strategy` matchable` (removeMembers suclheap (varlist agraph [aroot]),arule) <--- "newtest.symredarea.trace.loop ends") ---> "newtest.symredarea.trace.loop begins" + (stricts,rules,areas) = (fullfold (trc symbol) foldarea symbol trace <--- "newtest.symredarea.(,,).fullfold ends") ---> "newtest.symredarea.(,,).fullfold begins" matchable` = matchable (complete cli) strategy` = clistrategy cli |