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
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
|
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "Code.ag"
INCLUDE "Patterns.ag"
imports
{
import Data.Char (isAlphaNum)
import Pretty
import Code
import Options
import CommonTypes (attrname, _LOC, nullIdent)
import Data.List(intersperse)
import System.IO
import System.Directory
import System.FilePath
import CommonTypes(BlockInfo, BlockKind(..))
}
{
type PP_Docs = [PP_Doc]
}
{
ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeqH = ppMultiSeq' (>#<)
ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeqV = ppMultiSeq' (>-<)
ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeq' next strictArgs expr
= foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs
}
ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]
SEM Chunk
| Chunk
loc.outputfile = if sepSemMods @lhs.options
then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)
else @lhs.mainFile
ATTR Program [ options:{Options} | | output:{PP_Docs} ]
ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]
ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]
ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ]
SEM Program | Program
loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }
SEM Program
| Program chunks.nested = nest @lhs.options
SEM Exprs
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM CaseAlts
| Cons lhs.pps = @hd.pps ++ @tl.pps
| Nil lhs.pps = []
SEM DataAlts
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Types
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM NamedTypes
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Decls
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Chunks
| Cons lhs.pps = @hd.pps ++ @tl.pps
| Nil lhs.pps = []
SEM Program
| Program lhs.output = @chunks.pps
SEM Chunk
| Chunk lhs.pps = @comment.pp
: @info.pps
++ @dataDef.pps
++ @cataFun.pps
++ @semDom.pps
++ @semWrapper.pps
++ @semFunctions.pps
++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
SEM Decl
| Decl lhs.pp = @left.pp >#< "="
>-< indent 4 @rhs.pp
| Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp
| BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp
| Data lhs.pp = "data" >#< hv_sp (@name : @params)
>#< ( case @alts.pps of
[] -> empty
(x:xs) -> "=" >#< x
>-< vlist (map ("|" >#<) xs)
>-< if null @derivings
then empty
else "deriving" >#< ppTuple False (map text @derivings)
)
| NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp
| Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp
| TSig lhs.pp = @name >#< "::" >#< @tp.pp
| Comment lhs.pp = if '\n' `elem` @txt
then "{-" >-< vlist (lines @txt) >-< "-}"
else "--" >#< @txt
| PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}"
| Resume lhs.pp = if @monadic
then @left.pp >#< "<-" >#< @rhs.pp
else @left.pp >#< "=" >-< indent 4 @rhs.pp
| EvalDecl loc.strat = if breadthFirstStrict @lhs.options
then "stepwiseEval"
else "lazyEval"
lhs.pp = if breadthFirst @lhs.options
then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"
>-< indent 4 (
pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"
)
else @left.pp >#< "=" >#< @rhs.pp
SEM Expr
| Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps)
>-< "in " >#< @body.pp
)
| Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
>-< (vlist @alts.pps)
)
| Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps
>-< ("return" >#< @body.pp))
)
| Lambda loc.strictParams = if strictSems @lhs.options
then @args.pps
else []
loc.addBang = if bangpats @lhs.options
then \p -> pp_parens ("!" >|< p)
else id
lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
>-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
)
| TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps
| UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps
| App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps
| SimpleExpr lhs.pp = text @txt
| TextExpr lhs.pp = vlist (map text @lns)
| Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"")
>-< pp_parens @expr.pp
)
| PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}"
op = if @onNewLine
then (>-<)
else (>#<)
leftOp x y = if @onLeftSide
then x `op` y
else y
rightOp x y = if @onLeftSide
then x
else x `op` y
in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)
| LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}"
>-< ""
| TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp)
| ResultExpr lhs.pp = if breadthFirst @lhs.options
then "final" >#<
pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)
else @expr.pp
| InvokeExpr lhs.pp = if breadthFirst @lhs.options
then "invoke" >#< pp_parens @expr.pp >#< pp_parens (
@nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))
else @expr.pp >#< hv_sp @args.pps
| ResumeExpr lhs.pp = if breadthFirst @lhs.options
then pp_parens ("resume" >#< pp_parens @expr.pp
>-< indent 2 (pp_parens ( "\\" >|<
pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))
>#< "->"
>-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"
>-< indent 2 ("in" >#< @rhs.pp)
))))
else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
>-< ("{" >#< @left.pp >#< "->")
>-< indent 4 (@rhs.pp >#< "}")
)
| SemFun loc.strictParams = if strictSems @lhs.options
then @args.pps
else []
loc.addBang = if bangpats @lhs.options
then \p -> pp_parens ("!" >|< p)
else id
lhs.pp = if breadthFirst @lhs.options
then "Child" >#< pp_parens ( "\\" >|<
pp_parens (@nt >|< "_Inh" >#<
ppTuple False (map @loc.addBang @args.pps)) >#< "->"
>-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))
else if null @args.pps
then @body.pp
else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
>-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
)
SEM CaseAlt
| CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]
SEM DataAlt
| DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)
| Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps
SEM NamedType
| Named lhs.pp = if @strict
then @name >#< "::" >#< "!" >|< pp_parens @tp.pp
else @name >#< "::" >#< @tp.pp
SEM Lhs
| Pattern3 TupleLhs UnboxedTupleLhs
loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
| Pattern3
loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")
loc.hasStrictVars = not (null @pat3.strictVars)
| TupleLhs UnboxedTupleLhs
loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet
then map text @comps `ppMultiSeqH` (pp "True")
else pp "True"
loc.hasStrictVars = not (null @comps)
| Fun
loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
loc.hasStrictVars = not (null @args.pps)
loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True")
| TupleLhs UnboxedTupleLhs Fun
loc.addBang = if bangpats @lhs.options
then \p -> "!" >|< p
else id
| Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp
| Pattern3SM lhs.pp = @pat3.pp'
| TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)
| UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)
| Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))
| Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)
SEM Type [ | | prec:Int ]
| Arr lhs.prec = 2
.pp = @loc.l >#< "->" >-< @loc.r
loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp
.r = if @right.prec < 2 then pp_parens @right.pp else @right.pp
| TypeApp
lhs.pp = hv_sp (@func.pp : @args.pps)
| CtxApp
lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp
| QuantApp
lhs.pp = @left >#< @right.pp
| TupleType lhs.prec = 5
.pp = ppTuple @lhs.nested @tps.pps
| UnboxedTupleType lhs.prec = 5
.pp = ppUnboxedTuple @lhs.nested @tps.pps
| List lhs.prec = 5
.pp = "[" >|< @tp.pp >|< "]"
| SimpleType lhs.prec = 5
.pp = if reallySimple @txt then text @txt else pp_parens (text @txt)
| NontermType lhs.prec = 5
lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params
loc.prefix = if @deforested
then text "T_"
else empty
| TMaybe lhs.prec = 5
lhs.pp = text "Maybe" >#< pp_parens @tp.pp
| TEither lhs.prec = 5
lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp
| TMap lhs.prec = 5
lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp
| TIntMap lhs.prec = 5
lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp
| TSet lhs.prec = 5
lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp
| TIntSet lhs.prec = 5
lhs.pp = text "Data.IntSet.IntSet"
{
reallySimple :: String -> Bool
reallySimple = and . map (\x -> isAlphaNum x || x=='_')
ppTuple :: Bool -> [PP_Doc] -> PP_Doc
ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
ppTuple False pps = "(" >|< pp_block " " ")" "," pps
ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
}
-------------------------------------------------------------------------------
-- Strict data fields
-------------------------------------------------------------------------------
ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]
SEM Decl
| Data alts.strictPre = if @strict then pp "!" else empty
-------------------------------------------------------------------------------
-- Strict variables
-------------------------------------------------------------------------------
ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]
SEM Pattern
| Alias
loc.strictVar
= if strictCases @lhs.options && not @lhs.isDeclOfLet
then [@loc.ppVar]
else []
loc.strictPatVars
= if stricterCases @lhs.options && not @lhs.isDeclOfLet
then @pat.strictVars
else []
lhs.strictVars
= @loc.strictVar ++ @loc.strictPatVars
| Irrefutable
lhs.strictVars = []
-------------------------------------------------------------------------------
-- Pretty printing patterns
-------------------------------------------------------------------------------
SEM Patterns [ | | pps : {[PP_Doc]} ]
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Pattern
| Constr Product Alias
loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
then \p -> "!" >|< p
else id
SEM Pattern [ | | pp:PP_Doc ]
| Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
| Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps
| Alias loc.ppVar = pp (attrname @lhs.options False @field @attr)
loc.ppVarBang = @loc.addBang $ @loc.ppVar
lhs.pp = if @pat.isUnderscore
then @loc.ppVarBang
else @loc.ppVarBang >|< "@" >|< @pat.pp
| Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp
| Underscore lhs.pp = text "_"
SEM Pattern [ | | isUnderscore:{Bool}]
| Constr lhs.isUnderscore = False
| Product lhs.isUnderscore = False
| Alias lhs.isUnderscore = False
| Underscore lhs.isUnderscore = True
ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]
SEM Pattern
| Irrefutable
pat.belowIrrefutable = True
SEM Lhs
| Pattern3 Pattern3SM
pat3.belowIrrefutable = False
-------------------------------------------------------------------------------
-- Pretty printing patterns for SM
-------------------------------------------------------------------------------
SEM Patterns [ | | pps' : {[PP_Doc]} ]
| Cons lhs.pps' = @hd.pp' : @tl.pps'
| Nil lhs.pps' = []
SEM Pattern [ | | pp':PP_Doc ]
| Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
| Product lhs.pp' = pp_block "(" ")" "," @pats.pps'
| Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
| otherwise = attrname @lhs.options False @field @attr
in attribute >|< "@" >|< @pat.pp'
| Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp
| Underscore lhs.pp' = text "_"
{
locname' :: Identifier -> [Char]
locname' n = "_loc_" ++ getName n
}
-------------------------------------------------------------------------------
-- Determine if inside a Let
-------------------------------------------------------------------------------
ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]
SEM Program
| Program
chunks.isDeclOfLet = False
SEM Expr
| Let
decls.isDeclOfLet = True
| Do
stmts.isDeclOfLet = False
| ResumeExpr
left.isDeclOfLet = False
SEM CaseAlt
| CaseAlt
left.isDeclOfLet = False
-------------------------------------------------------------------------------
-- Alternative code printing to separate modules
-------------------------------------------------------------------------------
ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]
ATTR Program Chunks Chunk
[ importBlocks : PP_Doc
pragmaBlocks : String
textBlocks : PP_Doc
textBlockMap : {Map BlockInfo PP_Doc}
optionsLine : String
mainFile : String
mainName : String
moduleHeader : {String -> String -> String -> Bool -> String}
| | ]
SEM Program
| Program
loc.mainModuleFile = @lhs.mainFile
loc.genMainModule
= writeModule @loc.mainModuleFile
( [ pp $ @lhs.pragmaBlocks
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName "" "" False
, pp $ ("import " ++ @lhs.mainName ++ "_common\n")
]
++ map pp @chunks.imports
++ map vlist @chunks.appendMain
++ [@lhs.mainBlocksDoc]
)
loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
loc.genCommonModule
= writeModule @loc.commonFile
( [ pp $ @lhs.pragmaBlocks
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
, @lhs.importBlocks
, @lhs.textBlocks
]
++ map vlist @chunks.appendCommon
)
lhs.genIO = do @loc.genMainModule
@loc.genCommonModule
@chunks.genSems
{
renderDocs :: [PP_Doc] -> String
renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
}
ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]
SEM Chunk
| Chunk
lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]
ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]
SEM Chunk
| Chunk
lhs.appendCommon
= [ [@comment.pp]
, @dataDef.pps
, @semDom.pps
, if reference @lhs.options then @semWrapper.pps else []
]
lhs.appendMain
= [ [@comment.pp]
, @cataFun.pps
, if reference @lhs.options then [] else @semWrapper.pps
]
ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]
SEM Chunk
| Chunk
lhs.genSems
= writeModule @loc.outputfile
[ pp $ @lhs.pragmaBlocks
, pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True
, pp $ ("import " ++ @lhs.mainName ++ "_common\n")
, pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap
, @comment.pp
, vlist_sep "" @info.pps
, vlist_sep "" @semFunctions.pps
, Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap
]
SEM Chunk
| Chunk
loc.exports = concat $ intersperse "," @semNames
{
writeModule :: FilePath -> [PP_Doc] -> IO ()
writeModule path docs
= do bExists <- doesFileExist path
if bExists
then do input <- readFile path
seq (length input) (return ())
if input /= output
then dumpIt
else return ()
else dumpIt
where
output = renderDocs docs
dumpIt = writeFile path output
}
|
