diff options
| -rw-r--r-- | sucl/cli.icl | 4 | ||||
| -rw-r--r-- | sucl/loop.icl | 3 | ||||
| -rw-r--r-- | sucl/newfold.icl | 22 | ||||
| -rw-r--r-- | sucl/trace.dcl | 9 | ||||
| -rw-r--r-- | sucl/trace.icl | 52 |
5 files changed, 47 insertions, 43 deletions
diff --git a/sucl/cli.icl b/sucl/cli.icl index 90f731f..e7b3634 100644 --- a/sucl/cli.icl +++ b/sucl/cli.icl @@ -127,7 +127,7 @@ exports (CliAlias m) = m.exportedsymbols // Determine the arity of a core clean symbol arity :: Cli SuclSymbol -> Int arity (CliAlias m) sym -= extendfn m.arities (length o arguments o (extendfn m.typerules coretyperule)) sym += extendfn m.arities (length o arguments o (extendfn m.typerules (coretyperule--->"coreclean.coretyperule begins from cli.arity"))) sym /* > typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts @@ -177,7 +177,7 @@ typearity ti = length (arguments ti) //maxtypeinfo defs sym = extendfn defs coretypeinfo sym maxtyperule :: [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)] SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable -maxtyperule defs sym = extendfn defs coretyperule sym +maxtyperule defs sym = extendfn defs (coretyperule--->"cli.coretyperule begins from cli.maxtyperule") sym maxstricts :: [(SuclSymbol,[Bool])] SuclSymbol -> [Bool] maxstricts defs sym = extendfn defs corestricts sym diff --git a/sucl/loop.icl b/sucl/loop.icl index e589150..7c13d57 100644 --- a/sucl/loop.icl +++ b/sucl/loop.icl @@ -314,11 +314,12 @@ tryinstantiate onode rpattern anode sargs where act continue history failinfo instdone stricts sroot subject heap | anode==sroot // Check if strategy applied at root && goodorder strictargs sargs subject subject` // Check if order of arguments of rule ok - = Instantiate success fail + = Instantiate ipattern success fail = Stop where success = continue history failinfo True stricts` sroot subject` heap` fail = continue history failinfo` True stricts` sroot subject heap failinfo` = adjust onode [rpattern:failinfo onode] failinfo + ipattern = mkrgraph onode subject` (heap`,subject`) = rewrinstantiate pgraph proot onode (heap,subject) proot = rgraphroot rpattern; pgraph = rgraphgraph rpattern diff --git a/sucl/newfold.icl b/sucl/newfold.icl index 1e60c13..ce3e653 100644 --- a/sucl/newfold.icl +++ b/sucl/newfold.icl @@ -202,11 +202,11 @@ foldtips foldarea foldcont -> (foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)") ---> "newfold.foldtips.ft case = Stop" where deltanodes = foldoptional [] getdeltanodes answer rnfnodes = foldoptional [ruleroot rule] (const []) answer - Instantiate yestrace notrace + Instantiate ipattern yestrace notrace -> 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)") ---> "newfold.foldtips.ft case Instantiate/no" ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas)) - = ((True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)") ---> "newfold.foldtips.ft case Instantiate/yes" + = ((True,(stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)") ---> "newfold.foldtips.ft case Instantiate/yes" Reduce reductroot trace -> 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)") ---> "newfold.foldtips.ft case Reduce/no" @@ -218,14 +218,6 @@ foldtips foldarea foldcont where (Trace stricts rule answer _ transf) = trace exres = (False,newextract noetrc foldarea trace) -matchpattern :: - (Answer sym var pvar) - (FuncBody sym var) - (FuncBody sym var) - -> FuncBody sym var - -matchpattern _ _ _ = error "newfold: matchpattern: not yet implemented" - rule2body rule = buildgraph (arguments rule) (ruleroot rule) (rulegraph rule) addstrict stricts (body,areas) = (stricts,body,areas) @@ -277,8 +269,8 @@ newextract trc newname (Trace stricts rule answer history transf) -> newextract trc newname trace <--- "newfold.newextract ends (at Reduce transformation)" Annotate trace -> newextract trc newname trace <--- "newfold.newextract ends (at Annotate transformation)" - Instantiate yestrace notrace - -> (stricts,matchpattern answer yesbody nobody,yesareas++noareas) <--- "newfold.newextract ends (at Instantiate transformation)" + Instantiate ipattern yestrace notrace + -> (stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas) <--- "newfold.newextract ends (at Instantiate transformation)" where (_,yesbody,yesareas) = newextract trc newname yestrace (_,nobody,noareas) = newextract trc newname notrace Stop @@ -373,7 +365,7 @@ findpattern pattern thespinenodes residuroot (Reduce reductroot trace) fp residuroot trace = findpattern` pattern residuroot trace redirect = adjust (last thespinenodes) reductroot id -findpattern pattern thespinenodes residuroot (Instantiate yestrace notrace) +findpattern pattern thespinenodes residuroot (Instantiate ipattern yestrace notrace) = findpattern` pattern residuroot yestrace || findpattern` pattern residuroot notrace findpattern pattern thespinenodes residuroot (Annotate trace) @@ -407,9 +399,9 @@ getdeltanodes spine partial _ _ _ nodes = (False,nodes) redex _ _ = none -instance <<< FuncBody sym var | toString sym & ==,toString var +instance <<< (FuncBody sym var) | toString sym & ==,toString var where (<<<) file (MatchPattern pat yesbody nobody) - = file <<< "?Match: " <<< pat <<< nl + = file <<< "?Match: " /* <<< toString (rgraphroot pat) <<< " =?= " */ <<< pat <<< nl <<< "Match succes:" <<< nl <<< yesbody <<< "Match failure:" <<< nl diff --git a/sucl/trace.dcl b/sucl/trace.dcl index 6db2445..1964c66 100644 --- a/sucl/trace.dcl +++ b/sucl/trace.dcl @@ -163,7 +163,8 @@ Implementation = Reduce var (Trace sym var pvar) | Annotate (Trace sym var pvar) | Stop - | Instantiate (Trace sym var pvar) + | Instantiate (Rgraph sym var) + (Trace sym var pvar) (Trace sym var pvar) /* Disable the new abstraction node for now... @@ -259,7 +260,7 @@ been applied; this has to be done afterwards. > tips :: trace * ** *** -> [rule * **] > tips -> = foldtrace reduce annotate stop instantiate +> = oldtrace reduce annotate stop instantiate > where reduce stricts rule answer history reductroot = id > annotate stricts rule answer history = id > stop stricts rule answer history = [rule] @@ -283,7 +284,7 @@ foldtrace :: ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) var .result -> .result) ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) .result -> .result) ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) -> .result) - ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) .result .result -> .result) + ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) (Rgraph sym var) .result .result -> .result) !.(Trace sym var pvar) -> .result @@ -292,7 +293,7 @@ foldtransformation (var .result -> .subresult) (.result -> .subresult) .subresult - (.result .result -> .subresult) + ((Rgraph sym var) .result .result -> .subresult) ([.absresult] -> .subresult) ((Rule sym var) -> .absresult) (.result -> .absresult) diff --git a/sucl/trace.icl b/sucl/trace.icl index 48bfe68..2994757 100644 --- a/sucl/trace.icl +++ b/sucl/trace.icl @@ -129,7 +129,8 @@ Implementation = Reduce var (Trace sym var pvar) | Annotate (Trace sym var pvar) | Stop - | Instantiate (Trace sym var pvar) + | Instantiate (Rgraph sym var) + (Trace sym var pvar) (Trace sym var pvar) /* Disable the abstraction node for now... @@ -227,7 +228,7 @@ foldtrace :: ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) var .result -> .result) ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) .result -> .result) ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) -> .result) - ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) .result .result -> .result) + ([Bool] (Rule sym var) (Answer sym var pvar) (History sym var) (Rgraph sym var) .result .result -> .result) !.(Trace sym var pvar) -> .result @@ -238,7 +239,7 @@ foldtrace reduce annotate stop instantiate trace ftf stricts rule answer history (Reduce reductroot trace) = reduce stricts rule answer history reductroot (ftr trace) ftf stricts rule answer history (Annotate trace) = annotate stricts rule answer history (ftr trace) ftf stricts rule answer history Stop = stop stricts rule answer history - ftf stricts rule answer history (Instantiate yestrace notrace) = instantiate stricts rule answer history (ftr yestrace) (ftr notrace) + ftf stricts rule answer history (Instantiate ipattern yestrace notrace) = instantiate stricts rule answer history ipattern (ftr yestrace) (ftr notrace) // ftf _ _ _ _ (Abstract _) = error "foldtrace not implemented for abstraction nodes" foldtransformation @@ -246,7 +247,7 @@ foldtransformation (var .result -> .subresult) (.result -> .subresult) .subresult - (.result .result -> .subresult) + ((Rgraph sym var) .result .result -> .subresult) ([.absresult] -> .subresult) ((Rule sym var) -> .absresult) (.result -> .absresult) @@ -258,7 +259,7 @@ foldtransformation ftr reduce annotate stop instantiate abstract knownabstractio where ftf (Reduce reductroot trace) = reduce reductroot (ftr trace) ftf (Annotate trace) = annotate (ftr trace) ftf Stop = stop - ftf (Instantiate yestrace notrace) = instantiate (ftr yestrace) (ftr notrace) + ftf (Instantiate ipattern yestrace notrace) = instantiate ipattern (ftr yestrace) (ftr notrace) // ftf (Abstract as) = abstract (map fab as) // fab (NewAbstraction t) = newabstraction (ftr t) // fab (KnownAbstraction r) = knownabstraction r @@ -286,12 +287,13 @@ where // (<<<) file trace = error "trace.<<<(Trace): blocked for debugging" <<< "Transformation:" <<< nl writeTransformation transf where (Trace stricts rule answer history transf) = trace -instance <<< Transformation sym var pvar | toString sym & ==,toString,<<< var // & ==,toString,<<< pvar +instance <<< (Transformation sym var pvar) | toString sym & ==,toString,<<< var // & ==,toString,<<< pvar where (<<<) file (Reduce reductroot subtrace) = file <<< "Reduce; root of reduct: " <<< reductroot <<< nl <<< subtrace (<<<) file (Annotate subtrace) = file <<< "Annotate" <<< nl <<< subtrace (<<<) file Stop = file <<< "Stop" <<< nl - (<<<) file (Instantiate yestrace notrace) + (<<<) file (Instantiate ipattern yestrace notrace) = file <<< "Instantiate" <<< nl + // <<< "Pattern: " <<< ipattern <<< nl <<< "Successful match..." <<< nl <<< yestrace <<< "End of successful match." <<< nl @@ -299,20 +301,28 @@ where (<<<) file (Reduce reductroot subtrace) = file <<< "Reduce; root of reduct <<< notrace <<< "End of failing match." <<< nl -(writeTransformation) infixl :: *File .(Transformation sym var pvar) -> .File | toString sym & ==,toString,<<< var // & ==,toString,<<< pvar +(writeTransformation) infixl :: + *File + .(Transformation sym var pvar) + -> .File + | toString sym + & ==,toString,<<< var + // & ==,toString,<<< pvar + (writeTransformation) file (Reduce reductroot subtrace) - = file <<< "Reduce; root of reduct: " <<< reductroot <<< nl - writeTrace subtrace += file <<< "Reduce; root of reduct: " <<< reductroot <<< nl + writeTrace subtrace (writeTransformation) file (Annotate subtrace) - = file <<< "Annotate" <<< nl - writeTrace subtrace += file <<< "Annotate" <<< nl + writeTrace subtrace (writeTransformation) file Stop - = file <<< "Stop" <<< nl -(writeTransformation) file (Instantiate yestrace notrace) - = file <<< "Instantiate" <<< nl - <<< "Successful match..." <<< nl - // writeTrace yestrace - <<< "End of successful match." <<< nl - <<< "Failing match..." <<< nl - // writeTrace notrace - <<< "End of failing match." <<< nl += file <<< "Stop" <<< nl +(writeTransformation) file (Instantiate ipattern yestrace notrace) += file <<< "Instantiate" <<< nl + // <<< "Pattern: " <<< ipattern <<< nl + <<< "Successful match..." <<< nl + // writeTrace yestrace + <<< "End of successful match." <<< nl + <<< "Failing match..." <<< nl + // writeTrace notrace + <<< "End of failing match." <<< nl |