diff options
Diffstat (limited to 'sucl/cli.icl')
| -rw-r--r-- | sucl/cli.icl | 245 |
1 files changed, 245 insertions, 0 deletions
diff --git a/sucl/cli.icl b/sucl/cli.icl new file mode 100644 index 0000000..311bd0f --- /dev/null +++ b/sucl/cli.icl @@ -0,0 +1,245 @@ +cli.lit - Clean implementation modules +====================================== + +Description +----------- + +This script implements Clean modules (type module) and partial Clean +programs (type cli), which are essentially sets of Clean modules. + +------------------------------------------------------------ + +Interface +--------- + +Exported identifiers: + +> %export +> cli +> readcli +> loadclis +> exports +> typerule +> imports +> clistrategy +> constrs +> complete +> showcli +> printcli +> aliases +> macros +> stripexports + +> printalgebra + +Required types: + + identifier - type@source.lit type@source.lit + ... + +------------------------------------------------------------ + +Includes +-------- + +> %include "dnc.lit" + +> %include "../src/basic.lit" +> %include "../src/pfun.lit" +> %include "../src/graph.lit" +> %include "../src/rule.lit" +> %include "../src/spine.lit" +> %include "strat.lit" +> %include "law.lit" +> %include "../src/clean.lit" +> %include "../src/module.lit" + + +------------------------------------------------------------ + +Implementation +-------------- + +Implementation of identifier + + identifier + :: type + + identifierone arguments + = body + +... + +------------------------------------------------------------------------ + +Abstype implementation. + +> abstype cli +> with readcli :: [char] -> cli +> loadclis :: [[char]] -> cli +> exports :: cli -> [symbol] +> typerule :: cli -> symbol -> rule typesymbol typenode +> rules :: cli -> symbol -> optional [rule symbol node] +> imports :: cli -> [symbol] +> clistrategy :: cli -> (graph symbol node->node->**->bool) -> strategy symbol ** node **** +> constrs :: cli -> [(typesymbol,[symbol])] +> complete :: cli -> [symbol] -> bool +> showcli :: cli -> [char] +> aliases :: cli -> [(typesymbol,rule typesymbol typenode)] +> macros :: cli -> [(symbol,rule symbol node)] +> stripexports :: [char] -> cli -> cli + +> cli == module symbol node typesymbol typenode + +> readcli = compilecli.readcleanparts + +> loadclis +> = compilecli.concat.map readcleanparts + +> stripexports main (tdefs,(es,as,ts,rs)) = (tdefs,([User m i|User m i<-es;m=main],as,ts,rs)) + +> exports (tdefs,(es,as,ts,rs)) = es + +> typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts + +> rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs + +> imports (tdefs,(es,as,ts,rs)) = [sym|(sym,tdef)<-ts;~member (map fst rs) sym] + +> aliases ((tes,tas,tcs),defs) = tas +> macros (tdefs,(es,as,ts,rs)) = as + +> clistrategy ((tes,tas,tcs),(es,as,ts,rs)) matchable +> = ( checktype (maxtypeinfo ts). || Checks curried occurrences and strict arguments +> checklaws cleanlaws. || Checks for special (hard coded) rules (+x0=x /y1=y ...) +> checkrules matchable (foldmap id [] rs). +> || Checks normal rewrite rules +> checkimport islocal. || Checks for delta symbols +> checkconstr (member (concat (map snd tcs))) +> || Checks for constructors +> ) (corestrategy matchable) || Checks rules for symbols in the language core (IF, _AP, ...) +> where islocal (User m i) = member (map fst rs) (User m i) +> islocal rsym = True || Symbols in the language core are always completely known + +> maxtypeinfo :: [(symbol,(rule typesymbol typenode,[bool]))] -> symbol -> (rule typesymbol typenode,[bool]) +> maxtypeinfo ts = extendfn ts coretypeinfo + +> extendfn :: [(*,**)] -> (*->**) -> * -> ** +> extendfn mapping f x = foldmap id (f x) mapping x + +> constrs ((tes,tas,tcs),defs) = tcs + +> complete ((tes,tas,tcs),(es,as,ts,rs)) = mkclicomplete tcs (fst.maxtypeinfo ts) + +> showcli = printcli + +> mkclicomplete +> :: [(typesymbol,[symbol])] -> +> (symbol->rule typesymbol *****) -> +> [symbol] -> +> bool + +> mkclicomplete tcs typerule [] = False +> mkclicomplete tcs typerule syms +> = False, if ~tdef +> = foldmap superset (corecomplete tsym) tcs tsym syms, otherwise +> where trule = typerule (hd syms) +> (tdef,(tsym,targs)) = dnc (const "in mkclicomplete") (rulegraph trule) (rhs trule) + +------------------------------------------------------------------------ + +> printcli :: module symbol node typesymbol typenode -> [char] +> printcli ((tes,tas,tcs),(es,as,ts,rs)) +> = lay +> ( (implementation++"MODULE "++thismodule++";"): +> "": +> "<< EXPORT": +> map cleandef es++ +> ">>": +> "": +> map showimport (partition fst snd (itypesyms++isyms))++ +> concat (map cleanalg tcs)++ +> concat (map cleanimp [(sym,plookup showsymbol ts sym,rules)|(sym,rules)<-rs;usersym sym]) +> ) +> where cleandef sym = " "++cleantyperule sym (maxtypeinfo ts sym) +> cleanalg constr +> = ["","TYPE",printalgebra (fst.maxtypeinfo ts) constr], if typesymbolmodule (fst constr)=Present thismodule +> = [], otherwise +> cleanimp (sym,tinfo,rules) +> = prepend (trulelines++concat (map (cleanrule sym) rules)) +> where trulelines +> = [], if member (concat (map snd tcs)) sym +> = [cleantyperule sym tinfo], otherwise +> prepend [] = [] +> prepend lines = "":"RULE":lines +> implementation +> = "", if showsymbol (hd es)="Start" +> = "IMPLEMENTATION ", otherwise +> isyms = [(module,ident)|((User module ident),tinfo)<-ts;~member (map fst rs) (User module ident)] +> itypesyms +> = foldr add [] tcs +> where add (USER module ident,constrs) rest +> = (module,ident):foldr addc rest constrs, if module~=thismodule +> add typesymbol = id +> addc (User module ident) rest +> = (module,ident):rest +> addc symbol = id +> thismodule = foldoptional undef id (symbolmodule (hd es)) + +> showimport :: ([char],[[char]]) -> [char] +> showimport (module,idents) = "FROM "++module++" IMPORT "++join ',' idents++";" + +> printalgebra :: (symbol->rule typesymbol typenode) -> (typesymbol,[symbol]) -> [char] +> printalgebra typerule (tsym,syms) +> = ":: "++ +> showtypesymbol tsym++ +> concat (map ((' ':).showtypenode) trargs)++ +> concat (map2 (++) (" -> ":repeat " | ") alts)++ +> ";" +> where symtrules = map (pairwith typerule) syms +> trule = snd (hd symtrules) +> trroot = rhs trule +> (trdef,trcont) = dnc (const "in printalgebra") (rulegraph trule) trroot +> (trsym,trargs) +> = trcont, if trdef +> = (notrsym,notrargs), otherwise +> notrsym = error ("printalgebra: no type symbol for typenode "++showtypenode trroot) +> notrargs = error ("printalgebra: no type arguments for typenode "++showtypenode trroot) +> alts = map (printalt trargs) symtrules + +> printalt :: [typenode] -> (symbol,rule typesymbol typenode) -> [char] +> printalt trargs' (sym,trule) +> = showsymbol sym++concat (map (' ':) (printgraph showtypesymbol showtypenode tgraph' targs')) +> where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule +> (trdef,(trsym,trargs)) = dnc (const "in printalt") tgraph troot +> tnodes = trargs++(nodelist tgraph targs--trargs) +> tnodes' = trargs'++(typeheap--trargs') +> redirection = foldr (uncurry adjust) noredir (zip2 tnodes tnodes') +> noredir tnode = error ("printalt: no redirection for typenode "++showtypenode tnode) +> targs' = map redirection targs +> tgraph' = movegraph redirection tnodes tgraph + +Compiling clean parts into module information... + +> compilecli +> :: [cleanpart] -> +> module symbol node typesymbol typenode + +> compilecli parts +> = ((typeexports,aliases,typedefs),(exports,macros,typerules,locals)) +> where typeexports = [tsym|Typeexport tsym<-parts] +> aliases = [(tsym,compilerule targs troot tnodedefs)|Alias tsym targs troot tnodedefs<-parts] +> typedefs = [(tsym,syms)|Algebra tsym syms<-parts] +> exports = [sym|Export sym<-parts] +> macros = [(sym,compilerule args root nodedefs)|Macro sym args root nodedefs<-parts] +> typerules = [(sym,(compilerule targs troot tnodedefs,map (='!') stricts))|Type sym targs troot tnodedefs stricts<-parts] +> locals = [(sym,rules sym)|Rules sym<-parts] +> rules lsym = [compilerule args root nodedefs|Rule sym args root nodedefs<-parts;sym=lsym] + +> currytrule :: **** -> [*****] -> rule **** ***** -> rule **** ***** +> currytrule fn theap trule +> = mkrule ctargs ctroot ctgraph +> where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule +> ctargs = init targs +> ctroot = hd (theap--nodelist tgraph (troot:targs)) +> ctgraph = updategraph ctroot (fn,[last targs,troot]) tgraph |