aboutsummaryrefslogtreecommitdiff
path: root/sucl/cli.icl
diff options
context:
space:
mode:
Diffstat (limited to 'sucl/cli.icl')
-rw-r--r--sucl/cli.icl245
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