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
from rule import Rule
:: Module sym pvar tsym tvar
= { //exportedtypesymbols :: [tsym] // Exported type symbols (from DCL)
//, typealias :: [(tsym,Rule tsym tvar)] // Alias types
typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
//, aliases :: [(sym,Rule sym pvar)] // Macros
, typerules :: [(sym,(Rule tsym tvar,[Bool]))] // Info from type rules (actual type and argument strictnesses)
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
= { typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
, typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, stricts :: [(sym,[Bool])] // Strict arguments of functions
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
}
......@@ -27,49 +27,12 @@ Includes.
------------------------------------------------------------------------
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
= {// exportedtypesymbols :: [tsym] // Exported type symbols (from DCL)
//, typealias :: [(tsym,Rule tsym tvar)] // Alias types
typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
//, aliases :: [(sym,Rule sym pvar)] // Macros
, typerules :: [(sym,(Rule tsym tvar,[Bool]))] // Info from type rules (actual type and argument strictnesses)
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
= { typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
, typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, stricts :: [(sym,[Bool])] // Strict arguments of functions
, 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
exports :: Cli -> [SuclSymbol]
complete :: Cli -> [SuclSymbol] -> Bool
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]
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 m sym
= fst (maxtypeinfo m.typerules sym)
= maxtyperule m.typerules sym
/*
> rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
......@@ -154,7 +154,7 @@ typerule m sym
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
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 checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
o checkimport islocal // Checks for delta symbols
......@@ -163,11 +163,17 @@ clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
islocal rsym = True // Symbols in the language core are always completely known
typearity :: (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) -> Int
typearity ti = length (arguments (fst ti))
typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
typearity ti = length (arguments ti)
maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
maxtypeinfo defs sym = extendfn defs coretypeinfo sym
//maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
//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
......@@ -176,7 +182,7 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
*/
complete :: Cli -> [SuclSymbol] -> Bool
complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules)
complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/*
> showcli = printcli
......@@ -310,3 +316,19 @@ Compiling clean parts into module information...
> 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
instance == SuclVariable
// 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
corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool
......@@ -94,12 +94,15 @@ where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
(==) _ _ = False
// Get the type rule and strictness of a built in core clean symbol
coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
coretypeinfo sym
= (trule,corestricts sym)
where corestricts (SuclApply argc) = [True,False]
corestricts sym = map (const False) (arguments trule)
trule = coretyperule sym
corestricts :: SuclSymbol -> [Bool]
corestricts sym
= case sym
of (SuclApply argc)
-> maphd (const True) stricts
_
-> stricts
where stricts = map (const False) (arguments (coretyperule sym))
coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
coretyperule (SuclApply argc)
......
......@@ -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)
where used_conses = abort "supercompile: not implemented"
// Determine defined functions
_ = cts_function fun_defs
(sucl_typerules,sucl_stricts,sucl_bodies,sucl_kinds) = cts_function fun_defs
// 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
_ = 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
(expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef
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