1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
implementation module cli
// $Id$
/*
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
*/
|
