Commit 8ce9b3f2 authored by Vincent Zweije's avatar Vincent Zweije
Browse files

Combine stc conversion functions to produce a cli structure

Work out typerule/strictness separation in coreclean module
parent bc3f3995
...@@ -5,11 +5,9 @@ definition module absmodule ...@@ -5,11 +5,9 @@ definition module absmodule
from rule import Rule from rule import Rule
:: Module sym pvar tsym tvar :: Module sym pvar tsym tvar
= { //exportedtypesymbols :: [tsym] // Exported type symbols (from DCL) = { typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
//, typealias :: [(tsym,Rule tsym tvar)] // Alias types
typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols , exportedsymbols :: [sym] // Exported function/constructor symbols
//, aliases :: [(sym,Rule sym pvar)] // Macros , typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, typerules :: [(sym,(Rule tsym tvar,[Bool]))] // Info from type rules (actual type and argument strictnesses) , stricts :: [(sym,[Bool])] // Strict arguments of functions
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported , rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
} }
...@@ -27,49 +27,12 @@ Includes. ...@@ -27,49 +27,12 @@ Includes.
------------------------------------------------------------------------ ------------------------------------------------------------------------
Module implementation. Module implementation.
> module * *** **** *****
> == ( ( [****], || Exported types
> [(****,rule **** *****)], || Type alias rules
> [(****,[*])] || Constructor symbols for algebraic type symbol
> ),
> ( [*], || Exported symbols
> [(*,rule * ***)], || Alias rules
> [(*,(rule **** *****,[bool]))], || Typerule for symbol
> [(*,[rule * ***])] || Rewrite rules for symbol, absent if imported
> )
> )
*/ */
:: Module sym pvar tsym tvar :: Module sym pvar tsym tvar
= {// exportedtypesymbols :: [tsym] // Exported type symbols (from DCL) = { typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
//, typealias :: [(tsym,Rule tsym tvar)] // Alias types
typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols , exportedsymbols :: [sym] // Exported function/constructor symbols
//, aliases :: [(sym,Rule sym pvar)] // Macros , typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, typerules :: [(sym,(Rule tsym tvar,[Bool]))] // Info from type rules (actual type and argument strictnesses) , stricts :: [(sym,[Bool])] // Strict arguments of functions
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported , rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
} }
/*
> newmodule :: module * *** **** *****
> newmodule = (([],[],[]),([],[],[],[]))
> addtalias :: **** -> bool -> rule **** ***** -> module * *** **** ***** -> module * *** **** *****
> addtalias ts exp tr ((tes,tas,tcs),defs)
> = ((cond exp (ts:tes) tes,(ts,tr):tas,tcs),defs)
> addtsymdef :: **** -> bool -> [*] -> module * *** **** ***** -> module * *** **** *****
> addtsymdef ts exp ss ((tes,tas,tcs),defs)
> = ((cond exp (ts:tes) tes,tas,(ts,ss):tcs),defs)
> addalias :: * -> bool -> rule * *** -> module * *** **** ***** -> module * *** **** *****
> addalias s exp r (tdefs,(es,as,ts,rs))
> = (tdefs,(cond exp (s:es) es,(s,r):as,ts,rs))
> addsymdef :: * -> bool -> rule **** ***** -> bool -> [rule * ***] -> module * *** **** ***** -> module * *** **** *****
> addsymdef s exp t imp rr (tdefs,(es,as,ts,rs))
> = (tdefs,(cond exp (s:es) es,as,(s,(t,[])):ts,cond imp rs ((s,rr):rs)))
*/
...@@ -20,3 +20,12 @@ typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable ...@@ -20,3 +20,12 @@ typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
exports :: Cli -> [SuclSymbol] exports :: Cli -> [SuclSymbol]
complete :: Cli -> [SuclSymbol] -> Bool complete :: Cli -> [SuclSymbol] -> Bool
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
// Build a cli structure
mkcli ::
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])]
[SuclSymbol]
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclSymbol,[Rule SuclSymbol SuclVariable])]
-> Cli
...@@ -124,12 +124,12 @@ exports :: Cli -> [SuclSymbol] ...@@ -124,12 +124,12 @@ exports :: Cli -> [SuclSymbol]
exports m = m.exportedsymbols exports m = m.exportedsymbols
/* /*
> typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts > typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/ */
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
typerule m sym typerule m sym
= fst (maxtypeinfo m.typerules sym) = maxtyperule m.typerules sym
/* /*
> rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs > rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
...@@ -154,7 +154,7 @@ typerule m sym ...@@ -154,7 +154,7 @@ typerule 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 {typeconstructors=tcs,typerules=ts,rules=rs} matchable clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
= ( checkarity (typearity o maxtypeinfo ts) // Checks curried occurrences and strict arguments = ( checkarity (typearity o maxtyperule ts) // 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
...@@ -163,11 +163,17 @@ clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable ...@@ -163,11 +163,17 @@ clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs) where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
islocal rsym = True // Symbols in the language core are always completely known islocal rsym = True // Symbols in the language core are always completely known
typearity :: (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) -> Int typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
typearity ti = length (arguments (fst ti)) typearity ti = length (arguments ti)
maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) //maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
maxtypeinfo defs sym = extendfn defs coretypeinfo sym //maxtypeinfo defs sym = extendfn defs coretypeinfo sym
maxtyperule :: [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)] SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
maxtyperule defs sym = extendfn defs coretyperule sym
maxstricts :: [(SuclSymbol,[Bool])] SuclSymbol -> [Bool]
maxstricts defs sym = extendfn defs corestricts sym
/* /*
> constrs ((tes,tas,tcs),defs) = tcs > constrs ((tes,tas,tcs),defs) = tcs
...@@ -176,7 +182,7 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym ...@@ -176,7 +182,7 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
*/ */
complete :: Cli -> [SuclSymbol] -> Bool complete :: Cli -> [SuclSymbol] -> Bool
complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules) complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/* /*
> showcli = printcli > showcli = printcli
...@@ -310,3 +316,19 @@ Compiling clean parts into module information... ...@@ -310,3 +316,19 @@ Compiling clean parts into module information...
> ctgraph = updategraph ctroot (fn,[last targs,troot]) tgraph > ctgraph = updategraph ctroot (fn,[last targs,troot]) tgraph
*/ */
mkcli ::
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])]
[SuclSymbol]
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclSymbol,[Rule SuclSymbol SuclVariable])]
-> Cli
mkcli typerules stricts exports constrs bodies
= { typeconstructors = constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, rules = bodies
}
...@@ -59,7 +59,8 @@ instance == SuclSymbol ...@@ -59,7 +59,8 @@ instance == SuclSymbol
instance == SuclVariable instance == SuclVariable
// Get the type rule and strictness of a built in core clean symbol // Get the type rule and strictness of a built in core clean symbol
coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
corestricts :: SuclSymbol -> [Bool]
// Determine if a list of constructors completely covers a given type // Determine if a list of constructors completely covers a given type
corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool
...@@ -94,12 +94,15 @@ where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2 ...@@ -94,12 +94,15 @@ where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
(==) _ _ = False (==) _ _ = False
// Get the type rule and strictness of a built in core clean symbol // Get the type rule and strictness of a built in core clean symbol
coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
coretypeinfo sym corestricts :: SuclSymbol -> [Bool]
= (trule,corestricts sym) corestricts sym
where corestricts (SuclApply argc) = [True,False] = case sym
corestricts sym = map (const False) (arguments trule) of (SuclApply argc)
trule = coretyperule sym -> maphd (const True) stricts
_
-> stricts
where stricts = map (const False) (arguments (coretyperule sym))
coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
coretyperule (SuclApply argc) coretyperule (SuclApply argc)
......
...@@ -36,10 +36,12 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f ...@@ -36,10 +36,12 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f
= (components,fun_defs,dcl_types,used_conses,var_heap,type_heaps,expression_heap) = (components,fun_defs,dcl_types,used_conses,var_heap,type_heaps,expression_heap)
where used_conses = abort "supercompile: not implemented" where used_conses = abort "supercompile: not implemented"
// Determine defined functions // Determine defined functions
_ = cts_function fun_defs (sucl_typerules,sucl_stricts,sucl_bodies,sucl_kinds) = cts_function fun_defs
// Determine exported functions // Determine exported functions
_ = cts_exports fun_defs dcl_mods main_dcl_module_n sucl_exports = cts_exports fun_defs dcl_mods main_dcl_module_n
// Get constructor lists of algebraic types // Get constructor lists of algebraic types
_ = cts_getconstrs dcl_mods main_dcl_module_n sucl_constrs = cts_getconstrs dcl_mods main_dcl_module_n
// Build abstract CLI module
sucl_module = mkcli sucl_typerules sucl_stricts sucl_exports sucl_constrs sucl_bodies
// Convert sucl-generated function body back to core clean // Convert sucl-generated function body back to core clean
(expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef (expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef
Supports Markdown
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