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
|
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "Code.ag"
INCLUDE "Patterns.ag"
imports
{
import Pretty
import Code
import Patterns
import Options
import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)
import Data.List(intersperse,intercalate)
import Data.Char(toLower)
}
{
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
ppTuple :: Bool -> [PP_Doc] -> PP_Doc
ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
ppTuple False pps = "(" >|< pp_block " " ")" "," pps
}
--
-- Pass options down
--
ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ]
--
-- Collect outputs
--
ATTR Program [ | | output:{PP_Docs} ]
ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ]
ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ]
SEM Program
| Program lhs.output = @chunks.pps
SEM Exprs
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM CaseAlts
| Cons lhs.pps = @hd.pp : @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 Patterns
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
--
-- Individual cases
--
SEM Chunk
| Chunk lhs.pps = @comment.pp
: @info.pps
++ @dataDef.pps
++ @semDom.pps
++ @semFunctions.pps
++ @semWrapper.pps
++ @cataFun.pps
++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
SEM Decl
| Decl lhs.pp = if @lhs.isToplevel
then "let" >#< @left.pp >#< "="
>-< indent 4 @rhs.pp >#< ";;"
else "let" >#< @left.pp >#< "="
>-< indent 4 @rhs.pp >#< "in"
| Bind lhs.pp = error "pp of Decl.Bind not supported"
| BindLet lhs.pp = error "pp of Decl.BindLet not supported"
| Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name])
>#< ( case @alts.pps of
[] -> empty
(x:xs) -> "=" >#< x
>-< vlist (map ("|" >#<) xs)
)
>#< ";;"
| NewType lhs.pp = error "pp of Decl.NewType not supported"
| Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;"
| TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)"
| Comment lhs.pp = if '\n' `elem` @txt
then "(* " >-< vlist (lines @txt) >-< "*)"
else "(*" >#< @txt >#< "*)"
| PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported"
SEM Expr
| Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp])
| Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with"
>-< indent 2 ( case @alts.pps of
[] -> empty
(x:xs) -> " " >#< x
>-< vlist (map ("|" >#<) xs)
)
)
| Do lhs.pp = error "pp of Expr.Do not supported"
| Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->"
>-< indent 2 @body.pp )
| TupleExpr lhs.pp = ppTuple False @exprs.pps
| UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported"
| 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 = @expr.pp
| PragmaExpr lhs.pp = @expr.pp
| LineExpr lhs.pp = @expr.pp
| TypedExpr lhs.pp = @expr.pp
SEM Lhs
| Pattern3 lhs.pp = @pat3.pp
| Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported"
| TupleLhs lhs.pp = ppTuple False (map text @comps)
| UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported"
| Fun lhs.pp = @name >#< hv_sp @args.pps
| Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)
SEM Type
| Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp)
| CtxApp lhs.pp = error "pp of Type.CtxApp not supported"
| TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp]))
| TupleType lhs.pp = pp_block "(" ")" "," @tps.pps
| UnboxedTupleType
lhs.pp = error "pp of Type.UnboxedTupleType is not supported"
| List lhs.pp = @tp.pp >#< "list"
| SimpleType lhs.pp = text @txt
| NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name])
| TMaybe lhs.pp = @tp.pp >#< "opt"
| TEither lhs.pp = error "pp of Type.TEither is not supported"
| TMap lhs.pp = error "pp of Type.TMap is not supported"
| TIntMap lhs.pp = error "pp of Type.TIntMap is not supported"
| TSet lhs.pp = error "pp of Type.TSet is not supported"
| TIntSet lhs.pp = error "pp of Type.TIntSet is not supported"
{
toOcamlTC :: String -> String
toOcamlTC (c:cs) = toLower c : cs
toOcamlTC xs = xs
}
SEM CaseAlt
| CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp
SEM DataAlt
| DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps)
| Record lhs.pp = pp_block "{" "}" ";" @args.pps
SEM NamedType
| Named lhs.pp = @name >#< ":" >#< @tp.pp
SEM Pattern
| Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps
| Product lhs.pp = pp_block "(" ")" "," @pats.pps
| Alias -- assuming here that there is only an underscore under an alias
lhs.pp = if @pat.isUnderscore
then pp (attrname @lhs.options False @field @attr)
else error "pp of Pattern.Alias is only supported in the form (x@_)"
| Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported"
| Underscore lhs.pp = text "_"
SEM Pattern [ | | isUnderscore:{Bool}]
| Constr lhs.isUnderscore = False
| Product lhs.isUnderscore = False
| Alias lhs.isUnderscore = False
| Underscore lhs.isUnderscore = True
--
-- Determine if a declaration is toplevel
--
ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ]
SEM Program
| Program
chunks.isToplevel = True
SEM Expr
| Let
decls.isToplevel = False
| Do
stmts.isToplevel = False
|
