Commit 68570cb7 authored by Vincent Zweije's avatar Vincent Zweije

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

which included commits to RCS files with non-trunk default branches.
parent a63017bc
...@@ -107,7 +107,7 @@ Abstype implementation. ...@@ -107,7 +107,7 @@ Abstype implementation.
> stripexports :: [char] -> cli -> cli > stripexports :: [char] -> cli -> cli
*/ */
:: Cli = CliAlias (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable) :: Cli = CliAlias (SuclSymbol->String) (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable)
/* /*
> cli == module symbol node typesymbol typenode > cli == module symbol node typesymbol typenode
...@@ -123,11 +123,11 @@ Abstype implementation. ...@@ -123,11 +123,11 @@ Abstype implementation.
*/ */
exports :: Cli -> [SuclSymbol] exports :: Cli -> [SuclSymbol]
exports (CliAlias m) = m.exportedsymbols exports (CliAlias ss m) = m.exportedsymbols
// Determine the arity of a core clean symbol // Determine the arity of a core clean symbol
arity :: Cli SuclSymbol -> Int arity :: Cli SuclSymbol -> Int
arity (CliAlias m) sym arity (CliAlias ss m) sym
= extendfn m.arities (length o arguments o (extendfn m.typerules (coretyperule--->"coreclean.coretyperule begins from cli.arity"))) sym = extendfn m.arities (length o arguments o (extendfn m.typerules (coretyperule--->"coreclean.coretyperule begins from cli.arity"))) sym
/* /*
...@@ -135,7 +135,7 @@ arity (CliAlias m) sym ...@@ -135,7 +135,7 @@ arity (CliAlias m) sym
*/ */
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
typerule (CliAlias m) sym typerule (CliAlias ss m) sym
= maxtyperule m.typerules sym = maxtyperule m.typerules sym
/* /*
...@@ -160,8 +160,8 @@ typerule (CliAlias m) sym ...@@ -160,8 +160,8 @@ typerule (CliAlias m) sym
*/ */
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable clistrategy (CliAlias showsymbol {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable
= ( checkarity (extendfn as (typearity o maxtyperule ts)) // Checks curried occurrences and strict arguments = ( checkarity getarity // Checks curried occurrences and strict arguments
o checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...) o checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...)
o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
o checkimport islocal // Checks for delta symbols o checkimport islocal // Checks for delta symbols
...@@ -172,6 +172,9 @@ clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) m ...@@ -172,6 +172,9 @@ clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) m
where islocal rsym=:(SuclUser (SK_Function _)) = isMember rsym (map fst rs) // User-defined function symbols can be imported, so they're known if we have a list of rules for them where islocal rsym=:(SuclUser (SK_Function _)) = isMember rsym (map fst rs) // User-defined function symbols can be imported, so they're known if we have a list of rules for them
islocal _ = True // Symbols in the language core (the rest) are always completely known islocal _ = True // Symbols in the language core (the rest) are always completely known
// This includes lifted case symbols; we lifted them ourselves, after all // This includes lifted case symbols; we lifted them ourselves, after all
getarity sym
= (arity <--- ("cli.clistrategy.getarity ends with "+++toString arity)) ---> ("cli.clistrategy.getarity begins for "+++showsymbol sym)
where arity = extendfn as (typearity o (maxtyperule--->"cli.clistrategy.getarity uses maxtyperule") ts) sym
typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
typearity ti = length (arguments ti) typearity ti = length (arguments ti)
...@@ -192,7 +195,7 @@ maxstricts defs sym = extendfn defs corestricts sym ...@@ -192,7 +195,7 @@ maxstricts defs sym = extendfn defs corestricts sym
*/ */
complete :: Cli -> [SuclSymbol] -> Bool complete :: Cli -> [SuclSymbol] -> Bool
complete (CliAlias m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules) complete (CliAlias ss m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/* /*
> showcli = printcli > showcli = printcli
...@@ -328,16 +331,19 @@ Compiling clean parts into module information... ...@@ -328,16 +331,19 @@ Compiling clean parts into module information...
*/ */
mkcli :: mkcli ::
(SuclSymbol->String)
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)] [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])] [(SuclSymbol,[Bool])]
[SuclSymbol] [SuclSymbol]
[(SuclSymbol,Int)]
[(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])] [(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))] [(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
-> Cli -> Cli
mkcli typerules stricts exports constrs bodies mkcli showsymbol typerules stricts exports imports constrs bodies
= CliAlias = CliAlias
{ arities = map (mapsnd fst) bodies showsymbol
{ arities = map (mapsnd fst) bodies++imports
, typeconstructors = map (mapsnd (map fst)) constrs , typeconstructors = map (mapsnd (map fst)) constrs
, exportedsymbols = exports , exportedsymbols = exports
, typerules = typerules++flatten ((map (map (mapsnd fst) o snd)) constrs) , typerules = typerules++flatten ((map (map (mapsnd fst) o snd)) constrs)
...@@ -346,10 +352,12 @@ mkcli typerules stricts exports constrs bodies ...@@ -346,10 +352,12 @@ mkcli typerules stricts exports constrs bodies
} }
instance <<< Cli instance <<< Cli
where (<<<) file (CliAlias m) where (<<<) file (CliAlias showsymbol m)
= file <<< "=== Arities ===" <<< nl # file = file <<< "=== Arities ===" <<< nl
writeList m.arities # file = printlist (showpair showsymbol toString) "" m.arities file
<<< "=== Type Rules ===" <<< nl # file = file <<< "=== Type Rules ===" <<< nl
writeList m.typerules # file = printlist (showpair showsymbol toString) "" m.typerules file
<<< "=== Rules ===" <<< nl # file = file <<< "=== Rules ===" <<< nl
writeList m.rules # file = printlist (showpair showsymbol (showlist showrule`)) "" m.rules file
= file
where showrule` rule = showruleanch showsymbol toString (map (const False) (arguments rule)) rule []
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment