git.iko.soy/elk
on master help sign in
Make it possible to dealias types in errors and warnings
e33c47bEvan Czaplicki
src/AST/Expression/Canonical.hs+7−3
compare with master
unifiedsplit
@@ -28,11 +28,13 @@ data Def
28
28
29
29
30instance P.Pretty Def where
30instance P.Pretty Def where
31− pretty _ (Definition pattern expr maybeTipe) =
31+ pretty dealiaser _ (Definition pattern expr maybeTipe) =
32 P.vcat [ annotation, definition ]
32 P.vcat [ annotation, definition ]
33 where
33 where
34 definition =
34 definition =
35− P.pretty True pattern <+> P.equals <+> P.pretty False expr
35+ P.pretty dealiaser True pattern
36+ <+> P.equals
37+ <+> P.pretty dealiaser False expr
36
38
37 annotation =
39 annotation =
38 case maybeTipe of
40 case maybeTipe of
@@ -40,4 +42,6 @@ instance P.Pretty Def where
40 P.empty
42 P.empty
41
43
42 Just tipe ->
44 Just tipe ->
43− P.pretty True pattern <+> P.colon <+> P.pretty False tipe
45+ P.pretty dealiaser True pattern
46+ <+> P.colon
47+ <+> P.pretty dealiaser False tipe
src/AST/Expression/General.hs+33−33
@@ -113,53 +113,53 @@ dummyLet defs =
113-- PRETTY PRINTING
113-- PRETTY PRINTING
114
114
115instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
115instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
116− pretty needsParens expression =
116+ pretty dealiaser needsParens expression =
117 case expression of
117 case expression of
118 Literal literal ->
118 Literal literal ->
119− P.pretty needsParens literal
119+ P.pretty dealiaser needsParens literal
120
120
121 Var x ->
121 Var x ->
122− P.pretty needsParens x
122+ P.pretty dealiaser needsParens x
123
123
124 Range lowExpr highExpr ->
124 Range lowExpr highExpr ->
125 P.brackets $
125 P.brackets $
126− P.pretty False lowExpr
126+ P.pretty dealiaser False lowExpr
127 <> P.text ".."
127 <> P.text ".."
128− <> P.pretty False highExpr
128+ <> P.pretty dealiaser False highExpr
129
129
130 ExplicitList elements ->
130 ExplicitList elements ->
131− P.brackets (P.commaCat (map (P.pretty False) elements))
131+ P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))
132
132
133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
134 | Var.toString op == "-" ->
134 | Var.toString op == "-" ->
135− P.text "-" <> P.pretty True expr
135+ P.text "-" <> P.pretty dealiaser True expr
136
136
137 Binop op leftExpr rightExpr ->
137 Binop op leftExpr rightExpr ->
138 P.parensIf needsParens $
138 P.parensIf needsParens $
139 P.hang
139 P.hang
140− (P.pretty True leftExpr)
140+ (P.pretty dealiaser True leftExpr)
141 2
141 2
142− (P.text op'' <+> P.pretty True rightExpr)
142+ (P.text op'' <+> P.pretty dealiaser True rightExpr)
143 where
143 where
144 op' = Var.toString op
144 op' = Var.toString op
145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
146
146
147 Lambda pattern expr ->
147 Lambda pattern expr ->
148 P.parensIf needsParens $
148 P.parensIf needsParens $
149− P.text "\\" <> args <+> P.text "->" <+> P.pretty False body
149+ P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body
150 where
150 where
151 (patterns, body) =
151 (patterns, body) =
152 collectLambdas expr
152 collectLambdas expr
153
153
154 args =
154 args =
155− P.sep (map (P.pretty True) (pattern : patterns))
155+ P.sep (map (P.pretty dealiaser True) (pattern : patterns))
156
156
157 App expr arg ->
157 App expr arg ->
158 P.parensIf needsParens $
158 P.parensIf needsParens $
159 P.hang func 2 (P.sep args)
159 P.hang func 2 (P.sep args)
160 where
160 where
161 func:args =
161 func:args =
162− map (P.pretty True) (collectApps expr ++ [arg])
162+ map (P.pretty dealiaser True) (collectApps expr ++ [arg])
163
163
164 MultiIf branches ->
164 MultiIf branches ->
165 P.parensIf needsParens $
165 P.parensIf needsParens $
@@ -168,9 +168,9 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
168 iff (condition, branch) =
168 iff (condition, branch) =
169 P.text "|" <+>
169 P.text "|" <+>
170 P.hang
170 P.hang
171− (P.pretty False condition <+> P.text "->")
171+ (P.pretty dealiaser False condition <+> P.text "->")
172 2
172 2
173− (P.pretty False branch)
173+ (P.pretty dealiaser False branch)
174
174
175 Let defs body ->
175 Let defs body ->
176 P.parensIf needsParens $
176 P.parensIf needsParens $
@@ -178,8 +178,8 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
178 [ P.hang
178 [ P.hang
179 (P.text "let")
179 (P.text "let")
180 4
180 4
181− (P.vcat (map (P.pretty False) defs))
181+ (P.vcat (map (P.pretty dealiaser False) defs))
182− , P.text "in" <+> P.pretty False body
182+ , P.text "in" <+> P.pretty dealiaser False body
183 ]
183 ]
184
184
185 Case expr branches ->
185 Case expr branches ->
@@ -187,16 +187,16 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
187 P.hang pexpr 2 (P.vcat (map pretty' branches))
187 P.hang pexpr 2 (P.vcat (map pretty' branches))
188 where
188 where
189 pexpr =
189 pexpr =
190− P.text "case" <+> P.pretty False expr <+> P.text "of"
190+ P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"
191
191
192 pretty' (pattern, branch) =
192 pretty' (pattern, branch) =
193− P.pretty False pattern
193+ P.pretty dealiaser False pattern
194 <+> P.text "->"
194 <+> P.text "->"
195− <+> P.pretty False branch
195+ <+> P.pretty dealiaser False branch
196
196
197 Data "::" [hd,tl] ->
197 Data "::" [hd,tl] ->
198 P.parensIf needsParens $
198 P.parensIf needsParens $
199− P.pretty True hd <+> P.text "::" <+> P.pretty True tl
199+ P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl
200
200
201 Data "[]" [] ->
201 Data "[]" [] ->
202 P.text "[]"
202 P.text "[]"
@@ -204,49 +204,49 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
204 Data name exprs ->
204 Data name exprs ->
205 if Help.isTuple name
205 if Help.isTuple name
206 then
206 then
207− P.parens (P.commaCat (map (P.pretty False) exprs))
207+ P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))
208 else
208 else
209 P.parensIf (needsParens && not (null exprs)) $
209 P.parensIf (needsParens && not (null exprs)) $
210 P.hang
210 P.hang
211 (P.text name)
211 (P.text name)
212 2
212 2
213− (P.sep (map (P.pretty True) exprs))
213+ (P.sep (map (P.pretty dealiaser True) exprs))
214
214
215 Access record field ->
215 Access record field ->
216− P.pretty True record <> P.text "." <> P.text field
216+ P.pretty dealiaser True record <> P.text "." <> P.text field
217
217
218 Remove record field ->
218 Remove record field ->
219− P.braces (P.pretty False record <+> P.text "-" <+> P.text field)
219+ P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)
220
220
221 Insert (A.A _ (Remove record oldField)) newField expr ->
221 Insert (A.A _ (Remove record oldField)) newField expr ->
222 P.braces $
222 P.braces $
223 P.hsep
223 P.hsep
224− [ P.pretty False record
224+ [ P.pretty dealiaser False record
225 , P.text "-"
225 , P.text "-"
226 , P.text oldField
226 , P.text oldField
227 , P.text "|"
227 , P.text "|"
228 , P.text newField
228 , P.text newField
229 , P.equals
229 , P.equals
230− , P.pretty False expr
230+ , P.pretty dealiaser False expr
231 ]
231 ]
232
232
233 Insert record field expr ->
233 Insert record field expr ->
234 P.braces $
234 P.braces $
235− P.pretty False record
235+ P.pretty dealiaser False record
236 <+> P.text "|"
236 <+> P.text "|"
237 <+> P.text field
237 <+> P.text field
238 <+> P.equals
238 <+> P.equals
239− <+> P.pretty False expr
239+ <+> P.pretty dealiaser False expr
240
240
241 Modify record fields ->
241 Modify record fields ->
242 P.braces $
242 P.braces $
243 P.hang
243 P.hang
244− (P.pretty False record <+> P.text "|")
244+ (P.pretty dealiaser False record <+> P.text "|")
245 4
245 4
246 (P.commaSep $ map prettyField fields)
246 (P.commaSep $ map prettyField fields)
247 where
247 where
248 prettyField (field, expr) =
248 prettyField (field, expr) =
249− P.text field <+> P.text "<-" <+> P.pretty False expr
249+ P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr
250
250
251 Record fields ->
251 Record fields ->
252 P.sep
252 P.sep
@@ -255,17 +255,17 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
255 ]
255 ]
256 where
256 where
257 field (name, expr) =
257 field (name, expr) =
258− P.text name <+> P.equals <+> P.pretty False expr
258+ P.text name <+> P.equals <+> P.pretty dealiaser False expr
259
259
260 GLShader _ _ _ ->
260 GLShader _ _ _ ->
261 P.text "[glsl| ... |]"
261 P.text "[glsl| ... |]"
262
262
263 Port portImpl ->
263 Port portImpl ->
264− P.pretty needsParens portImpl
264+ P.pretty dealiaser needsParens portImpl
265
265
266
266
267instance P.Pretty (PortImpl expr tipe) where
267instance P.Pretty (PortImpl expr tipe) where
268− pretty _ impl =
268+ pretty _ _ impl =
269 P.text ("<port:" ++ portName impl ++ ">")
269 P.text ("<port:" ++ portName impl ++ ">")
270
270
271
271
src/AST/Literal.hs+1−1
@@ -17,7 +17,7 @@ data Literal
17
17
18
18
19instance P.Pretty Literal where
19instance P.Pretty Literal where
20− pretty _ literal =
20+ pretty _ _ literal =
21 case literal of
21 case literal of
22 IntNum n -> P.int n
22 IntNum n -> P.int n
23 FloatNum n -> P.double n
23 FloatNum n -> P.double n
src/AST/Pattern.hs+7−7
@@ -103,29 +103,29 @@ boundVarList pattern =
103-- PRETTY PRINTING
103-- PRETTY PRINTING
104
104
105instance Var.ToString var => P.Pretty (Pattern' ann var) where
105instance Var.ToString var => P.Pretty (Pattern' ann var) where
106− pretty needsParens pattern =
106+ pretty dealiaser needsParens pattern =
107 case pattern of
107 case pattern of
108 Var name ->
108 Var name ->
109 P.text name
109 P.text name
110
110
111 Literal literal ->
111 Literal literal ->
112− P.pretty needsParens literal
112+ P.pretty dealiaser needsParens literal
113
113
114 Record fields ->
114 Record fields ->
115 P.braces (P.commaCat (map P.text fields))
115 P.braces (P.commaCat (map P.text fields))
116
116
117 Alias x ptrn ->
117 Alias x ptrn ->
118 P.parensIf needsParens $
118 P.parensIf needsParens $
119− P.pretty True ptrn <+> P.text "as" <+> P.text x
119+ P.pretty dealiaser True ptrn <+> P.text "as" <+> P.text x
120
120
121 Anything ->
121 Anything ->
122 P.text "_"
122 P.text "_"
123
123
124 Data name [A.A _ hd, A.A _ tl]
124 Data name [A.A _ hd, A.A _ tl]
125 | Var.toString name == "::" ->
125 | Var.toString name == "::" ->
126− P.parensIf isCons (P.pretty False hd)
126+ P.parensIf isCons (P.pretty dealiaser False hd)
127 <+> P.text "::"
127 <+> P.text "::"
128− <+> P.pretty False tl
128+ <+> P.pretty dealiaser False tl
129 where
129 where
130 isCons =
130 isCons =
131 case hd of
131 case hd of
@@ -137,7 +137,7 @@ instance Var.ToString var => P.Pretty (Pattern' ann var) where
137 in
137 in
138 if Help.isTuple name'
138 if Help.isTuple name'
139 then
139 then
140− P.parens (P.commaCat (map (P.pretty False) patterns))
140+ P.parens (P.commaCat (map (P.pretty dealiaser False) patterns))
141 else
141 else
142 P.parensIf needsParens $
142 P.parensIf needsParens $
143− P.hsep (P.text name' : map (P.pretty True) patterns)
143+ P.hsep (P.text name' : map (P.pretty dealiaser True) patterns)
src/AST/Type.hs+36−37
@@ -1,7 +1,7 @@
1module AST.Type
1module AST.Type
2 ( Raw, Raw'(..)
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
3 , Canonical(..), Aliased(..)
4− , Port(..), portType
4+ , Port(..), getPortType
5 , deepDealias, dealias
5 , deepDealias, dealias
6 , collectLambdas
6 , collectLambdas
7 , fieldMap
7 , fieldMap
@@ -59,8 +59,8 @@ data Port t
59 deriving (Show)
59 deriving (Show)
60
60
61
61
62−portType :: Port tipe -> tipe
62+getPortType :: Port tipe -> tipe
63−portType portType =
63+getPortType portType =
64 case portType of
64 case portType of
65 Normal tipe -> tipe
65 Normal tipe -> tipe
66 Signal tipe _ -> tipe
66 Signal tipe _ -> tipe
@@ -152,88 +152,87 @@ dealiasHelp typeTable tipe =
152-- PRETTY PRINTING
152-- PRETTY PRINTING
153
153
154instance (P.Pretty t) => P.Pretty (Port t) where
154instance (P.Pretty t) => P.Pretty (Port t) where
155− pretty needsParens portType =
155+ pretty dealiaser needsParens portType =
156− case portType of
156+ P.pretty dealiaser needsParens (getPortType portType)
157− Normal tipe ->
158− P.pretty needsParens tipe
159−
160− Signal tipe _ ->
161− P.pretty needsParens tipe
162
157
163
158
164instance P.Pretty Raw' where
159instance P.Pretty Raw' where
165− pretty needsParens tipe =
160+ pretty dealiaser needsParens tipe =
166 case tipe of
161 case tipe of
167 RLambda arg body ->
162 RLambda arg body ->
168− P.parensIf needsParens (prettyLambda getRawLambda arg body)
163+ P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)
169
164
170 RVar x ->
165 RVar x ->
171 P.text x
166 P.text x
172
167
173 RType var ->
168 RType var ->
174− prettyType var
169+ prettyType dealiaser var
175
170
176 RApp func args ->
171 RApp func args ->
177 let
172 let
178 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
173 isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)
179 isTuple _ = False
174 isTuple _ = False
180 in
175 in
181− prettyApp needsParens isTuple func args
176+ prettyApp dealiaser needsParens isTuple func args
182
177
183 RRecord fields ext ->
178 RRecord fields ext ->
184− prettyRecord (flattenRawRecord fields ext)
179+ prettyRecord dealiaser (flattenRawRecord fields ext)
185
180
186
181
187instance P.Pretty Canonical where
182instance P.Pretty Canonical where
188− pretty needsParens tipe =
183+ pretty dealiaser needsParens tipe =
189 case tipe of
184 case tipe of
190 Lambda arg body ->
185 Lambda arg body ->
191− P.parensIf needsParens (prettyLambda getCanLambda arg body)
186+ P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)
192
187
193 Var x ->
188 Var x ->
194 P.text x
189 P.text x
195
190
196 Type var ->
191 Type var ->
197− prettyType var
192+ prettyType dealiaser var
198
193
199 App func args ->
194 App func args ->
200 let
195 let
201 isTuple (Type name) = Help.isTuple (Var.toString name)
196 isTuple (Type name) = Help.isTuple (Var.toString name)
202 isTuple _ = False
197 isTuple _ = False
203 in
198 in
204− prettyApp needsParens isTuple func args
199+ prettyApp dealiaser needsParens isTuple func args
205
200
206 Record fields ext ->
201 Record fields ext ->
207− prettyRecord (flattenCanRecord fields ext)
202+ prettyRecord dealiaser (flattenCanRecord fields ext)
208
203
209 Aliased name args _ ->
204 Aliased name args _ ->
210 P.parensIf (needsParens && not (null args)) $
205 P.parensIf (needsParens && not (null args)) $
211 P.hang
206 P.hang
212− (P.pretty False name)
207+ (P.pretty dealiaser False name)
213 2
208 2
214− (P.sep (map (P.pretty True . snd) args))
209+ (P.sep (map (P.pretty dealiaser True . snd) args))
215
210
216
211
217-- PRETTY HELPERS
212-- PRETTY HELPERS
218
213
219−prettyType :: (Var.ToString var) => var -> P.Doc
214+prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc
220−prettyType var =
215+prettyType dealiaser var =
221 let
216 let
222 v = Var.toString var
217 v = Var.toString var
223 in
218 in
219+ P.text $
224− P.text (if v == "_Tuple0" then "()" else v)
220+ if v == "_Tuple0" then
221+ "()"
222+ else
223+ maybe v id (Map.lookup v dealiaser)
225
224
226
225
227-- PRETTY LAMBDAS
226-- PRETTY LAMBDAS
228
227
229−prettyLambda :: (P.Pretty t) => (t -> Maybe (t,t)) -> t -> t -> P.Doc
228+prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc
230−prettyLambda getLambda arg body =
229+prettyLambda dealiaser getLambda arg body =
231 let
230 let
232 rest =
231 rest =
233 gatherLambda getLambda body
232 gatherLambda getLambda body
234
233
235 prettyArg t =
234 prettyArg t =
236− P.pretty (Maybe.isJust (getLambda t)) t
235+ P.pretty dealiaser (Maybe.isJust (getLambda t)) t
237 in
236 in
238 P.sep
237 P.sep
239 [ prettyArg arg
238 [ prettyArg arg
@@ -272,33 +271,33 @@ collectLambdas tipe =
272
271
273-- PRETTY APP
272-- PRETTY APP
274
273
275−prettyApp :: (P.Pretty t) => Bool -> (t -> Bool) -> t -> [t] -> P.Doc
274+prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc
276−prettyApp needsParens isTuple func args
275+prettyApp dealiaser needsParens isTuple func args
277 | isTuple func =
276 | isTuple func =
278 P.parens $ P.sep $
277 P.parens $ P.sep $
279− P.punctuate P.comma (map (P.pretty False) args)
278+ P.punctuate P.comma (map (P.pretty dealiaser False) args)
280
279
281 | null args =
280 | null args =
282− P.pretty needsParens func
281+ P.pretty dealiaser needsParens func
283
282
284 | otherwise =
283 | otherwise =
285 P.parensIf needsParens $
284 P.parensIf needsParens $
286 P.hang
285 P.hang
287− (P.pretty True func)
286+ (P.pretty dealiaser True func)
288 2
287 2
289− (P.sep (map (P.pretty True) args))
288+ (P.sep (map (P.pretty dealiaser True) args))
290
289
291
290
292-- PRETTY RECORD
291-- PRETTY RECORD
293
292
294−prettyRecord :: (P.Pretty t) => ([(String, t)], Maybe String) -> P.Doc
293+prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc
295−prettyRecord recordInfo =
294+prettyRecord dealiaser recordInfo =
296 let
295 let
297 prettyField (field, tipe) =
296 prettyField (field, tipe) =
298 P.hang
297 P.hang
299 (P.text field <+> P.text ":")
298 (P.text field <+> P.text ":")
300 4
299 4
301− (P.pretty False tipe)
300+ (P.pretty dealiaser False tipe)
302 in
301 in
303 case recordInfo of
302 case recordInfo of
304 ([], Nothing) ->
303 ([], Nothing) ->
src/AST/Variable.hs+11−7
@@ -3,6 +3,7 @@ module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
4import Data.Binary
5import qualified Data.List as List
5import qualified Data.List as List
6+import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import qualified Data.Maybe as Maybe
7import Text.PrettyPrint as P
8import Text.PrettyPrint as P
8
9
@@ -203,26 +204,29 @@ getUnion value =
203-- PRETTY VARIABLES
204-- PRETTY VARIABLES
204
205
205instance P.Pretty Raw where
206instance P.Pretty Raw where
206− pretty _ (Raw name) =
207+ pretty _ _ (Raw name) =
207 if Help.isOp name
208 if Help.isOp name
208 then P.parens (P.text name)
209 then P.parens (P.text name)
209 else P.text name
210 else P.text name
210
211
211
212
212instance P.Pretty Canonical where
213instance P.Pretty Canonical where
213− pretty _ var =
214+ pretty dealiaser _ var =
214− P.text (toString var)
215+ let
216+ name = toString var
217+ in
218+ P.text (maybe name id (Map.lookup name dealiaser))
215
219
216
220
217instance P.Pretty a => P.Pretty (Listing a) where
221instance P.Pretty a => P.Pretty (Listing a) where
218− pretty _ (Listing explicits open) =
222+ pretty dealiaser _ (Listing explicits open) =
219 let dots = [if open then P.text ".." else P.empty]
223 let dots = [if open then P.text ".." else P.empty]
220 in
224 in
221− P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))
225+ P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
222
226
223
227
224instance P.Pretty Value where
228instance P.Pretty Value where
225− pretty _ portable =
229+ pretty dealiaser _ portable =
226 case portable of
230 case portable of
227 Value name ->
231 Value name ->
228 P.text name
232 P.text name
@@ -231,7 +235,7 @@ instance P.Pretty Value where
231 P.text name
235 P.text name
232
236
233 Union name ctors ->
237 Union name ctors ->
234− P.text name <> P.pretty False ctors
238+ P.text name <> P.pretty dealiaser False ctors
235
239
236
240
237-- BINARY SERIALIZATION
241-- BINARY SERIALIZATION
src/Canonicalize.hs+7−5
@@ -44,8 +44,9 @@ module' interfaces modul =
44 moduleHelp interfaces modul
44 moduleHelp interfaces modul
45 in
45 in
46 case rawResults of
46 case rawResults of
47− Result.Ok almostCanonicalModule ->
47+ Result.Ok (env, almostCanonicalModule) ->
48+ R.addDealiaser (Env.toDealiaser env) $
48− filterImports uses almostCanonicalModule
49+ filterImports uses almostCanonicalModule
49
50
50 Result.Err msgs ->
51 Result.Err msgs ->
51 R.throwMany (map (A.map Error.Canonicalize) msgs)
52 R.throwMany (map (A.map Error.Canonicalize) msgs)
@@ -61,13 +62,14 @@ type AlmostCanonicalModule =
61moduleHelp
62moduleHelp
62 :: Module.Interfaces
63 :: Module.Interfaces
63 -> Module.ValidModule
64 -> Module.ValidModule
64− -> Result.ResultErr AlmostCanonicalModule
65+ -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)
65moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
66moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
66 canonicalModule
67 canonicalModule
67 <$> canonicalDeclsResult
68 <$> canonicalDeclsResult
68 <*> resolveExports locals exports
69 <*> resolveExports locals exports
69 where
70 where
70− canonicalModule canonicalDecls canonicalExports =
71+ canonicalModule (env, canonicalDecls) canonicalExports =
72+ (,) env $
71 modul
73 modul
72 { Module.exports = canonicalExports
74 { Module.exports = canonicalExports
73 , Module.body = body canonicalDecls
75 , Module.body = body canonicalDecls
@@ -79,7 +81,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
79
81
80 canonicalDeclsResult =
82 canonicalDeclsResult =
81 Setup.environment interfaces modul
83 Setup.environment interfaces modul
82− `Result.andThen` \env -> T.traverse (declaration env) decls
84+ `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls
83
85
84 body :: [D.CanonicalDecl] -> Module.CanonicalBody
86 body :: [D.CanonicalDecl] -> Module.CanonicalBody
85 body decls =
87 body decls =
src/Canonicalize/Declaration.hs+3−3
@@ -70,13 +70,13 @@ toDefs moduleName (A.A region decl) =
70 in
70 in
71 case impl of
71 case impl of
72 E.In name tipe ->
72 E.In name tipe ->
73− [ definition name body (T.portType tipe) ]
73+ [ definition name body (T.getPortType tipe) ]
74
74
75 E.Out name _expr tipe ->
75 E.Out name _expr tipe ->
76− [ definition name body (T.portType tipe) ]
76+ [ definition name body (T.getPortType tipe) ]
77
77
78 E.Task name _expr tipe ->
78 E.Task name _expr tipe ->
79− [ definition name body (T.portType tipe) ]
79+ [ definition name body (T.getPortType tipe) ]
80
80
81 -- no constraints are needed for fixity declarations
81 -- no constraints are needed for fixity declarations
82 D.Fixity _ _ _ ->
82 D.Fixity _ _ _ ->
src/Canonicalize/Environment.hs+34
@@ -3,6 +3,7 @@ module Canonicalize.Environment where
3
3
4import qualified Data.List as List
4import qualified Data.List as List
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6+import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
7import qualified Data.Set as Set
7
8
8import AST.Expression.General (saveEnvName)
9import AST.Expression.General (saveEnvName)
@@ -10,6 +11,7 @@ import qualified AST.Module as Module
10import qualified AST.Pattern as P
11import qualified AST.Pattern as P
11import qualified AST.Type as Type
12import qualified AST.Type as Type
12import qualified AST.Variable as Var
13import qualified AST.Variable as Var
14+import Elm.Utils ((|>))
13
15
14
16
15-- ENVIRONMENT
17-- ENVIRONMENT
@@ -104,3 +106,35 @@ builtinPatches =
104 toTuple :: Int -> (String, Int)
106 toTuple :: Int -> (String, Int)
105 toTuple n =
107 toTuple n =
106 ("_Tuple" ++ show n, n)
108 ("_Tuple" ++ show n, n)
109+
110+
111+-- TO TYPE DEALIASER
112+
113+toDealiaser :: Environment -> Map.Map String String
114+toDealiaser (Env _ _ adts aliases _) =
115+ let
116+ dealiasAdt (localName, canonicalSet) =
117+ case Set.toList canonicalSet of
118+ [canonicalName] ->
119+ Just (Var.toString canonicalName, localName)
120+ _ ->
121+ Nothing
122+
123+ dealiasAlias (localName, canonicalSet) =
124+ case Set.toList canonicalSet of
125+ [(canonicalName,_,_)] ->
126+ Just (Var.toString canonicalName, localName)
127+ _ ->
128+ Nothing
129+
130+ adtPairs =
131+ Maybe.mapMaybe dealiasAdt (Map.toList adts)
132+
133+ aliasPairs =
134+ Maybe.mapMaybe dealiasAlias (Map.toList aliases)
135+
136+ add (key,value) dict =
137+ Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict
138+ in
139+ adtPairs ++ aliasPairs
140+ |> foldr add Map.empty
src/Elm/Compiler.hs+38−23
@@ -2,6 +2,7 @@
2module Elm.Compiler
2module Elm.Compiler
3 ( version, rawVersion
3 ( version, rawVersion
4 , parseDependencies, compile
4 , parseDependencies, compile
5+ , Dealiaser, dummyDealiaser
5 , Error, errorToString, errorToJson, printError
6 , Error, errorToString, errorToJson, printError
6 , Warning, warningToString, warningToJson, printWarning
7 , Warning, warningToString, warningToJson, printWarning
7 ) where
8 ) where
@@ -18,6 +19,7 @@ import qualified Parse.Module as Parse
18import qualified Parse.Parse as Parse
19import qualified Parse.Parse as Parse
19import qualified Reporting.Annotation as A
20import qualified Reporting.Annotation as A
20import qualified Reporting.Error as Error
21import qualified Reporting.Error as Error
22+import qualified Reporting.PrettyPrint as P
21import qualified Reporting.Result as Result
23import qualified Reporting.Result as Result
22import qualified Reporting.Warning as Warning
24import qualified Reporting.Warning as Warning
23
25
@@ -64,15 +66,15 @@ compile
64 -> Bool
66 -> Bool
65 -> String
67 -> String
66 -> Map.Map PublicModule.Name PublicModule.Interface
68 -> Map.Map PublicModule.Name PublicModule.Interface
67− -> ([Warning], Either [Error] (PublicModule.Interface, String))
69+ -> (Dealiaser, [Warning], Either [Error] (PublicModule.Interface, String))
68compile user packageName isRoot source interfaces =
70compile user packageName isRoot source interfaces =
69 let unwrappedInterfaces =
71 let unwrappedInterfaces =
70 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
72 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces
71
73
72− (Result.Result warnings rawResult) =
74+ (Result.Result (dealiaser, warnings) rawResult) =
73 Compile.compile user packageName isRoot unwrappedInterfaces source
75 Compile.compile user packageName isRoot unwrappedInterfaces source
74 in
76 in
75− (,) (map Warning warnings) $
77+ (,,) (maybe dummyDealiaser Dealiaser dealiaser) (map Warning warnings) $
76 case rawResult of
78 case rawResult of
77 Result.Ok modul ->
79 Result.Ok modul ->
78 Right (Module.toInterface modul, JS.generate modul)
80 Right (Module.toInterface modul, JS.generate modul)
@@ -81,43 +83,56 @@ compile user packageName isRoot source interfaces =
81 Left (map Error errors)
83 Left (map Error errors)
82
84
83
85
86+-- DEALIASER
87+
88+newtype Dealiaser =
89+ Dealiaser P.Dealiaser
90+
91+
92+dummyDealiaser :: Dealiaser
93+dummyDealiaser =
94+ Dealiaser Map.empty
95+
96+
84-- ERRORS
97-- ERRORS
85
98
99+newtype Error =
86−newtype Error = Error (A.Located Error.Error)
100+ Error (A.Located Error.Error)
87
101
88
102
89−errorToString :: String -> String -> Error -> String
103+errorToString :: Dealiaser -> String -> String -> Error -> String
90−errorToString location source (Error err) =
104+errorToString (Dealiaser dealiaser) location source (Error err) =
91− Error.toString location source err
105+ Error.toString dealiaser location source err
92
106
93
107
94−printError :: String -> String -> Error -> IO ()
108+printError :: Dealiaser -> String -> String -> Error -> IO ()
95−printError location source (Error err) =
109+printError (Dealiaser dealiaser) location source (Error err) =
96− Error.print location source err
110+ Error.print dealiaser location source err
97
111
98
112
99−errorToJson :: String -> Error -> Json.Value
113+errorToJson :: Dealiaser -> String -> Error -> Json.Value
100−errorToJson location (Error err) =
114+errorToJson (Dealiaser dealiaser) location (Error err) =
101− Error.toJson location err
115+ Error.toJson dealiaser location err
102
116
103
117
104-- WARNINGS
118-- WARNINGS
105
119
120+newtype Warning =
106−newtype Warning = Warning (A.Located Warning.Warning)
121+ Warning (A.Located Warning.Warning)
107
122
108
123
109−warningToString :: String -> String -> Warning -> String
124+warningToString :: Dealiaser -> String -> String -> Warning -> String
110−warningToString location source (Warning err) =
125+warningToString (Dealiaser dealiaser) location source (Warning err) =
111− Warning.toString location source err
126+ Warning.toString dealiaser location source err
112
127
113
128
114−printWarning :: String -> String -> Warning -> IO ()
129+printWarning :: Dealiaser -> String -> String -> Warning -> IO ()
115−printWarning location source (Warning err) =
130+printWarning (Dealiaser dealiaser) location source (Warning err) =
116− Warning.print location source err
131+ Warning.print dealiaser location source err
117
132
118
133
119−warningToJson :: String -> Warning -> Json.Value
134+warningToJson :: Dealiaser -> String -> Warning -> Json.Value
120−warningToJson location (Warning err) =
135+warningToJson (Dealiaser dealiaser) location (Warning err) =
121− Warning.toJson location err
136+ Warning.toJson dealiaser location err
122
137
123
138
src/Generate/JavaScript/Port.hs+3−2
@@ -1,6 +1,7 @@
1module Generate.JavaScript.Port (inbound, outbound, task) where
1module Generate.JavaScript.Port (inbound, outbound, task) where
2
2
3import qualified Data.List as List
3import qualified Data.List as List
4+import qualified Data.Map as Map
4import Language.ECMAScript3.Syntax
5import Language.ECMAScript3.Syntax
5
6
6import qualified AST.Type as T
7import qualified AST.Type as T
@@ -96,14 +97,14 @@ inbound name portType =
96 T.Normal tipe ->
97 T.Normal tipe ->
97 _Port "inbound" `call`
98 _Port "inbound" `call`
98 [ string name
99 [ string name
99− , string (show (P.pretty False tipe))
100+ , string (show (P.pretty Map.empty False tipe))
100 , toTypeFunction tipe
101 , toTypeFunction tipe
101 ]
102 ]
102
103
103 T.Signal _root arg ->
104 T.Signal _root arg ->
104 _Port "inboundSignal" `call`
105 _Port "inboundSignal" `call`
105 [ string name
106 [ string name
106− , string (show (P.pretty False arg))
107+ , string (show (P.pretty Map.empty False arg))
107 , toTypeFunction arg
108 , toTypeFunction arg
108 ]
109 ]
109
110
src/Reporting/Annotation.hs+2−2
@@ -52,5 +52,5 @@ drop (A _ value) =
52-- PRETTY PRINT
52-- PRETTY PRINT
53
53
54instance (P.Pretty a) => P.Pretty (Annotated info a) where
54instance (P.Pretty a) => P.Pretty (Annotated info a) where
55− pretty parens (A _ value) =
55+ pretty dealiaser parens (A _ value) =
56− P.pretty parens value
56+ P.pretty dealiaser parens value
src/Reporting/Error.hs+17−16
@@ -10,6 +10,7 @@ import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Canonicalize as Canonicalize
10import qualified Reporting.Error.Canonicalize as Canonicalize
11import qualified Reporting.Error.Syntax as Syntax
11import qualified Reporting.Error.Syntax as Syntax
12import qualified Reporting.Error.Type as Type
12import qualified Reporting.Error.Type as Type
13+import qualified Reporting.PrettyPrint as P
13import qualified Reporting.Report as Report
14import qualified Reporting.Report as Report
14
15
15
16
@@ -23,40 +24,40 @@ data Error
23
24
24-- TO REPORT
25-- TO REPORT
25
26
26−toReport :: Error -> Report.Report
27+toReport :: P.Dealiaser -> Error -> Report.Report
27−toReport err =
28+toReport dealiaser err =
28 case err of
29 case err of
29 Syntax syntaxError ->
30 Syntax syntaxError ->
30− Syntax.toReport syntaxError
31+ Syntax.toReport dealiaser syntaxError
31
32
32 Canonicalize canonicalizeError ->
33 Canonicalize canonicalizeError ->
33− Canonicalize.toReport canonicalizeError
34+ Canonicalize.toReport dealiaser canonicalizeError
34
35
35 Type typeError ->
36 Type typeError ->
36− Type.toReport typeError
37+ Type.toReport dealiaser typeError
37
38
38
39
39-- TO STRING
40-- TO STRING
40
41
41−toString :: String -> String -> A.Located Error -> String
42+toString :: P.Dealiaser -> String -> String -> A.Located Error -> String
42−toString location source (A.A region err) =
43+toString dealiaser location source (A.A region err) =
43− Report.toString location region (toReport err) source
44+ Report.toString location region (toReport dealiaser err) source
44
45
45
46
46−print :: String -> String -> A.Located Error -> IO ()
47+print :: P.Dealiaser -> String -> String -> A.Located Error -> IO ()
47−print location source (A.A region err) =
48+print dealiaser location source (A.A region err) =
48− Report.printError location region (toReport err) source
49+ Report.printError location region (toReport dealiaser err) source
49
50
50
51
51-- TO JSON
52-- TO JSON
52
53
53−toJson :: FilePath -> A.Located Error -> Json.Value
54+toJson :: P.Dealiaser -> FilePath -> A.Located Error -> Json.Value
54−toJson filePath (A.A region err) =
55+toJson dealiaser filePath (A.A region err) =
55 let
56 let
56 (maybeRegion, additionalFields) =
57 (maybeRegion, additionalFields) =
57 case err of
58 case err of
58 Syntax syntaxError ->
59 Syntax syntaxError ->
59− Report.toJson [] (Syntax.toReport syntaxError)
60+ Report.toJson [] (Syntax.toReport dealiaser syntaxError)
60
61
61 Canonicalize canonicalizeError ->
62 Canonicalize canonicalizeError ->
62 let
63 let
@@ -65,10 +66,10 @@ toJson filePath (A.A region err) =
65 (\s -> ["suggestions" .= s])
66 (\s -> ["suggestions" .= s])
66 (Canonicalize.extractSuggestions canonicalizeError)
67 (Canonicalize.extractSuggestions canonicalizeError)
67 in
68 in
68− Report.toJson suggestions (Canonicalize.toReport canonicalizeError)
69+ Report.toJson suggestions (Canonicalize.toReport dealiaser canonicalizeError)
69
70
70 Type typeError ->
71 Type typeError ->
71− Report.toJson [] (Type.toReport typeError)
72+ Report.toJson [] (Type.toReport dealiaser typeError)
72 in
73 in
73 Json.object $
74 Json.object $
74 [ "file" .= filePath
75 [ "file" .= filePath
src/Reporting/Error/Canonicalize.hs+4−4
@@ -135,8 +135,8 @@ namingError pre post =
135 Report.simple "NAMING ERROR" pre post
135 Report.simple "NAMING ERROR" pre post
136
136
137
137
138−toReport :: Error -> Report.Report
138+toReport :: P.Dealiaser -> Error -> Report.Report
139−toReport err =
139+toReport dealiaser err =
140 case err of
140 case err of
141 Var (VarError kind name problem suggestions) ->
141 Var (VarError kind name problem suggestions) ->
142 let var = kind ++ " '" ++ name ++ "'"
142 let var = kind ++ " '" ++ name ++ "'"
@@ -179,7 +179,7 @@ toReport err =
179 ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"
179 ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"
180 ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"
180 ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"
181 ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="
181 ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="
182− ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))
182+ ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty dealiaser True tipe)))
183 ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"
183 ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"
184 ++ "like List which are recursive, but do not get expanded into infinite types."
184 ++ "like List which are recursive, but do not get expanded into infinite types."
185
185
@@ -224,7 +224,7 @@ toReport err =
224
224
225 postHint =
225 postHint =
226 "The specific unsupported type is:\n\n"
226 "The specific unsupported type is:\n\n"
227− ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"
227+ ++ P.render (P.nest 4 (P.pretty dealiaser False localType)) ++ "\n\n"
228 ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"
228 ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"
229 ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"
229 ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"
230 ++ "Json.Values, and concrete records."
230 ++ "Json.Values, and concrete records."
src/Reporting/Error/Syntax.hs+4−4
@@ -28,8 +28,8 @@ data Error
28
28
29-- TO REPORT
29-- TO REPORT
30
30
31−toReport :: Error -> Report.Report
31+toReport :: P.Dealiaser -> Error -> Report.Report
32−toReport err =
32+toReport dealiaser err =
33 case err of
33 case err of
34 Parse messages ->
34 Parse messages ->
35 parseErrorReport messages
35 parseErrorReport messages
@@ -110,7 +110,7 @@ toReport err =
110 P.hang
110 P.hang
111 (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)
111 (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)
112 4
112 4
113− (P.pretty False tipe)
113+ (P.pretty dealiaser False tipe)
114 where
114 where
115 vars = map P.text (givenVars ++ tvar : tvars)
115 vars = map P.text (givenVars ++ tvar : tvars)
116
116
@@ -128,7 +128,7 @@ toReport err =
128 (|>) = flip ($)
128 (|>) = flip ($)
129 vars = map P.text (givenVars ++ tvar : tvars)
129 vars = map P.text (givenVars ++ tvar : tvars)
130 toDoc (ctor, args) =
130 toDoc (ctor, args) =
131− P.text ctor <+> P.hsep (map (P.pretty True) args)
131+ P.text ctor <+> P.hsep (map (P.pretty dealiaser True) args)
132
132
133
133
134unboundTypeVars :: String -> String -> [String] -> String -> Report.Report
134unboundTypeVars :: String -> String -> [String] -> String -> Report.Report
src/Reporting/Error/Type.hs+6−6
@@ -50,8 +50,8 @@ data Note
50
50
51-- TO REPORT
51-- TO REPORT
52
52
53−toReport :: Error -> Report.Report
53+toReport :: P.Dealiaser -> Error -> Report.Report
54−toReport err =
54+toReport dealiaser err =
55 case err of
55 case err of
56 Mismatch (MismatchInfo hint leftType rightType note) ->
56 Mismatch (MismatchInfo hint leftType rightType note) ->
57 let
57 let
@@ -59,9 +59,9 @@ toReport err =
59
59
60 postHint =
60 postHint =
61 "To be more specific, type inference is leading to a conflict between this type:\n\n"
61 "To be more specific, type inference is leading to a conflict between this type:\n\n"
62− ++ P.render (P.nest 4 (P.pretty False leftType))
62+ ++ P.render (P.nest 4 (P.pretty dealiaser False leftType))
63 ++ "\n\nand this type:\n\n"
63 ++ "\n\nand this type:\n\n"
64− ++ P.render (P.nest 4 (P.pretty False rightType))
64+ ++ P.render (P.nest 4 (P.pretty dealiaser False rightType))
65 in
65 in
66 case note of
66 case note of
67 PreNote msg ->
67 PreNote msg ->
@@ -78,7 +78,7 @@ toReport err =
78 "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"
78 "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"
79 ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"
79 ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"
80 ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"
80 ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"
81− ++ P.render (P.nest 4 (P.pretty False tipe))
81+ ++ P.render (P.nest 4 (P.pretty dealiaser False tipe))
82 ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"
82 ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"
83 ++ "expanded this type, it would just keep getting bigger and bigger."
83 ++ "expanded this type, it would just keep getting bigger and bigger."
84
84
@@ -86,7 +86,7 @@ toReport err =
86 Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $
86 Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $
87 "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"
87 "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"
88 ++ "on screen, but you gave me:\n\n"
88 ++ "on screen, but you gave me:\n\n"
89− ++ P.render (P.nest 4 (P.pretty False tipe))
89+ ++ P.render (P.nest 4 (P.pretty dealiaser False tipe))
90
90
91
91
92hintToString :: Hint -> (Maybe Region.Region, String)
92hintToString :: Hint -> (Maybe Region.Region, String)
src/Reporting/PrettyPrint.hs+14−2
@@ -1,19 +1,31 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2module Reporting.PrettyPrint where
2module Reporting.PrettyPrint where
3
3
4+import qualified Data.Map as Map
4import Text.PrettyPrint as P
5import Text.PrettyPrint as P
6+
5import qualified AST.Helpers as Help
7import qualified AST.Helpers as Help
6
8
7
9
10+-- PRETTY
11+
8class Pretty a where
12class Pretty a where
9− pretty :: Bool -> a -> Doc
13+ pretty :: Dealiaser -> Bool -> a -> Doc
14+
10
15
16+type Dealiaser =
17+ Map.Map String String
18+
19+
20+-- INSTANCES
11
21
12instance Pretty String where
22instance Pretty String where
13− pretty _ str =
23+ pretty _ _ str =
14 P.text str
24 P.text str
15
25
16
26
27+-- HELPERS
28+
17commaCat :: [Doc] -> Doc
29commaCat :: [Doc] -> Doc
18commaCat docs =
30commaCat docs =
19 cat (punctuate comma docs)
31 cat (punctuate comma docs)
src/Reporting/Result.hs+31−15
@@ -1,17 +1,21 @@
1module Reporting.Result where
1module Reporting.Result where
2
2
3−import qualified Control.Applicative as A
3+import Control.Applicative (Applicative, (<*>), (<|>), pure)
4import qualified Control.Monad as M
4import qualified Control.Monad as M
5import Control.Monad.Except (Except, runExcept)
5import Control.Monad.Except (Except, runExcept)
6
6
7import qualified Reporting.Annotation as A
7import qualified Reporting.Annotation as A
8import qualified Reporting.Region as R
8import qualified Reporting.Region as R
9+import qualified Reporting.PrettyPrint as P
9
10
10
11
11-- TASK
12-- TASK
12
13
13data Result warning error result =
14data Result warning error result =
15+ Result
16+ (Maybe P.Dealiaser, [A.Located warning])
14− Result [A.Located warning] (RawResult [A.Located error] result)
17+ (RawResult [A.Located error] result)
18+
15
19
16data RawResult e a
20data RawResult e a
17 = Ok a
21 = Ok a
@@ -22,17 +26,17 @@ data RawResult e a
22
26
23ok :: a -> Result w e a
27ok :: a -> Result w e a
24ok value =
28ok value =
25− Result [] (Ok value)
29+ Result (Nothing, []) (Ok value)
26
30
27
31
28throw :: R.Region -> e -> Result w e a
32throw :: R.Region -> e -> Result w e a
29throw region err =
33throw region err =
30− Result [] (Err [A.A region err])
34+ Result (Nothing, []) (Err [A.A region err])
31
35
32
36
33throwMany :: [A.Located e] -> Result w e a
37throwMany :: [A.Located e] -> Result w e a
34throwMany errors =
38throwMany errors =
35− Result [] (Err errors)
39+ Result (Nothing, []) (Err errors)
36
40
37
41
38from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
42from :: (e -> e') -> Except [A.Located e] a -> Result w e' a
@@ -58,12 +62,17 @@ mapError f (Result warnings rawResult) =
58
62
59warn :: R.Region -> w -> Result w e ()
63warn :: R.Region -> w -> Result w e ()
60warn region warning =
64warn region warning =
61− Result [A.A region warning] (Ok ())
65+ Result (Nothing, [A.A region warning]) (Ok ())
62
66
63
67
64addWarnings :: [A.Located w] -> Result w e a -> Result w e a
68addWarnings :: [A.Located w] -> Result w e a -> Result w e a
65−addWarnings newWarnings (Result warnings rawResult) =
69+addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =
66− Result (newWarnings ++ warnings) rawResult
70+ Result (dealiaser, newWarnings ++ warnings) rawResult
71+
72+
73+addDealiaser :: P.Dealiaser -> Result w e a -> Result w e a
74+addDealiaser dealiaser (Result (_, warnings) rawResult) =
75+ Result (Just dealiaser, warnings) rawResult
67
76
68
77
69-- EXTRA FANCY HELPERS
78-- EXTRA FANCY HELPERS
@@ -78,12 +87,12 @@ instance M.Functor (Result w e) where
78 Result warnings (Err msgs)
87 Result warnings (Err msgs)
79
88
80
89
81−instance A.Applicative (Result w e) where
90+instance Applicative (Result w e) where
82 pure value =
91 pure value =
83 ok value
92 ok value
84
93
85− (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =
94+ (<*>) (Result context resultFunc) (Result context' resultVal) =
86− Result (warnings ++ warnings') $
95+ Result (merge context context') $
87 case (resultFunc, resultVal) of
96 case (resultFunc, resultVal) of
88 (Ok func, Ok val) ->
97 (Ok func, Ok val) ->
89 Ok (func val)
98 Ok (func val)
@@ -102,12 +111,19 @@ instance M.Monad (Result w e) where
102 return value =
111 return value =
103 ok value
112 ok value
104
113
105− (>>=) (Result warnings rawResult) callback =
114+ (>>=) (Result context rawResult) callback =
106 case rawResult of
115 case rawResult of
107 Err msg ->
116 Err msg ->
108− Result warnings (Err msg)
117+ Result context (Err msg)
109
118
110 Ok value ->
119 Ok value ->
111− let (Result warnings' rawResult') = callback value
120+ let (Result context' rawResult') = callback value
112 in
121 in
113− Result (warnings ++ warnings') rawResult'
122+ Result (merge context context') rawResult'
123+
124+
125+merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])
126+merge (dealiaser, warnings) (dealiaser', warnings') =
127+ ( dealiaser <|> dealiaser'
128+ , warnings ++ warnings'
129+ )
src/Reporting/Warning.hs+12−12
@@ -23,18 +23,18 @@ data Warning
23
23
24-- TO STRING
24-- TO STRING
25
25
26−toString :: String -> String -> A.Located Warning -> String
26+toString :: P.Dealiaser -> String -> String -> A.Located Warning -> String
27−toString location source (A.A region warning) =
27+toString dealiaser location source (A.A region warning) =
28− Report.toString location region (toReport warning) source
28+ Report.toString location region (toReport dealiaser warning) source
29
29
30
30
31−print :: String -> String -> A.Located Warning -> IO ()
31+print :: P.Dealiaser -> String -> String -> A.Located Warning -> IO ()
32−print location source (A.A region warning) =
32+print dealiaser location source (A.A region warning) =
33− Report.printWarning location region (toReport warning) source
33+ Report.printWarning location region (toReport dealiaser warning) source
34
34
35
35
36−toReport :: Warning -> Report.Report
36+toReport :: P.Dealiaser -> Warning -> Report.Report
37−toReport warning =
37+toReport dealiaser warning =
38 case warning of
38 case warning of
39 UnusedImport moduleName ->
39 UnusedImport moduleName ->
40 Report.simple
40 Report.simple
@@ -54,16 +54,16 @@ toReport warning =
54 P.hang
54 P.hang
55 (P.text name <+> P.colon)
55 (P.text name <+> P.colon)
56 4
56 4
57− (P.pretty False inferredType)
57+ (P.pretty dealiaser False inferredType)
58
58
59
59
60-- TO JSON
60-- TO JSON
61
61
62−toJson :: FilePath -> A.Located Warning -> Json.Value
62+toJson :: P.Dealiaser -> FilePath -> A.Located Warning -> Json.Value
63−toJson filePath (A.A region warning) =
63+toJson dealiaser filePath (A.A region warning) =
64 let
64 let
65 (maybeRegion, additionalFields) =
65 (maybeRegion, additionalFields) =
66− Report.toJson [] (toReport warning)
66+ Report.toJson [] (toReport dealiaser warning)
67 in
67 in
68 Json.object $
68 Json.object $
69 [ "file" .= filePath
69 [ "file" .= filePath
tests/Test/Compiler.hs+8−9
@@ -1,7 +1,6 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Test.Compiler (compilerTests) where
2module Test.Compiler (compilerTests) where
3
3
4−import Control.Arrow (second)
5import qualified Data.Map as Map
4import qualified Data.Map as Map
6import Data.Traversable (traverse)
5import Data.Traversable (traverse)
7
6
@@ -46,7 +45,7 @@ testsDir =
46-- RUN COMPILER
45-- RUN COMPILER
47
46
48testIf
47testIf
49− :: (([Compiler.Warning], Either String (Module.Interface, String)) -> Assertion)
48+ :: (Either String (Module.Interface, String) -> Assertion)
50 -> [FilePath]
49 -> [FilePath]
51 -> IO [Test]
50 -> IO [Test]
52testIf handleResult filePaths =
51testIf handleResult filePaths =
@@ -55,20 +54,20 @@ testIf handleResult filePaths =
55 setupTest filePath = do
54 setupTest filePath = do
56 source <- readFile filePath
55 source <- readFile filePath
57
56
58− let result =
57+ let (dealiaser, _warnings, result) =
59 Compiler.compile "elm-lang" "core" True source Map.empty
58 Compiler.compile "elm-lang" "core" True source Map.empty
60 let formatErrors errors =
59 let formatErrors errors =
61− concatMap (Compiler.errorToString filePath source) errors
60+ concatMap (Compiler.errorToString dealiaser filePath source) errors
62 let formattedResult =
61 let formattedResult =
63− second (either (Left . formatErrors) Right) result
62+ either (Left . formatErrors) Right result
64
63
65 return $ testCase filePath (handleResult formattedResult)
64 return $ testCase filePath (handleResult formattedResult)
66
65
67
66
68-- CHECK RESULTS
67-- CHECK RESULTS
69
68
70−isSuccess :: ([Compiler.Warning], Either String a) -> Assertion
69+isSuccess :: Either String a -> Assertion
71−isSuccess (_, result) =
70+isSuccess result =
72 case result of
71 case result of
73 Right _ ->
72 Right _ ->
74 assertBool "" True
73 assertBool "" True
@@ -77,8 +76,8 @@ isSuccess (_, result) =
77 assertFailure errorMessages
76 assertFailure errorMessages
78
77
79
78
80−isFailure :: ([Compiler.Warning], Either a b) -> Assertion
79+isFailure :: Either a b -> Assertion
81−isFailure (_, result) =
80+isFailure result =
82 case result of
81 case result of
83 Right _ ->
82 Right _ ->
84 assertFailure "Compilation succeeded but should have failed"
83 assertFailure "Compilation succeeded but should have failed"