git.iko.soy/elk
on master help sign in
Make errors for binary operators much more specific

Resolves https://github.com/evancz/error-message-catalog/issues/3

commit43d4388bfbb9ec0d5f3eebd45a1064b396be7118 authorEvan Czaplicki <info@elm-lang.org> dateSun 10 May 2015, 18:50 (11 years ago) parent7be0e81
2 files changed+62−9
compare with master
unifiedsplit
src/Reporting/Error/Type.hs+27 src/Type/Constrain/Expression.hs+35−9
src/Reporting/Error/Type.hs+27
@@ -3,7 +3,9 @@ module Reporting.Error.Type where
33
44import qualified Text.PrettyPrint as P
55
6+import qualified AST.Helpers as Help
67import qualified AST.Type as Type
8+import qualified AST.Variable as Var
79import qualified Reporting.PrettyPrint as P
810import qualified Reporting.Region as Region
911import qualified Reporting.Report as Report
@@ -32,6 +34,9 @@ data Hint
3234 | If
3335 | List
3436 | ListElement Int Region.Region
37+ | BinopLeft Var.Canonical Region.Region
38+ | BinopRight Var.Canonical Region.Region
39+ | Binop Var.Canonical
3540
3641
3742data Note
@@ -135,3 +140,25 @@ hintToString hint =
135140 ++ "type does not match how it is used elsewhere."
136141 )
137142
143+ BinopLeft op region ->
144+ ( Just region
145+ , "The left argument of " ++ prettyOperator op ++ " is causing a type mismatch."
146+ )
147+
148+ BinopRight op region ->
149+ ( Just region
150+ , "The right argument of " ++ prettyOperator op ++ " is causing a type mismatch."
151+ )
152+
153+ Binop op ->
154+ ( Nothing
155+ , "The two arguments to " ++ prettyOperator op ++ " are fine, but the overall type of this expression\n"
156+ ++ "does not match how it is used elsewhere."
157+ )
158+
159+
160+prettyOperator :: Var.Canonical -> String
161+prettyOperator (Var.Canonical _ opName) =
162+ if Help.isOp opName
163+ then "(" ++ opName ++ ")"
164+ else "`" ++ opName ++ "`"
src/Type/Constrain/Expression.hs+35−9
@@ -74,15 +74,7 @@ constrain env (A.A region expression) tipe =
7474 constrainList env region exprs tipe
7575
7676 E.Binop op leftExpr rightExpr ->
77− exists $ \leftType ->
78− exists $ \rightType ->
79− do leftCon <- constrain env leftExpr leftType
80− rightCon <- constrain env rightExpr rightType
81− return $ CAnd
82− [ leftCon
83− , rightCon
84− , V.toString op <? (leftType ==> rightType ==> tipe)
85− ]
77+ constrainBinop env region op leftExpr rightExpr tipe
8678
8779 E.Lambda pattern body ->
8880 exists $ \argType ->
@@ -188,6 +180,40 @@ constrain env (A.A region expression) tipe =
188180 constrain env expr tipe
189181
190182
183+-- CONSTRAIN BINOP
184+
185+constrainBinop
186+ :: Env.Environment
187+ -> R.Region
188+ -> V.Canonical
189+ -> Canonical.Expr
190+ -> Canonical.Expr
191+ -> Type
192+ -> IO TypeConstraint
193+constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =
194+ do leftVar <- variable Flexible
195+ rightVar <- variable Flexible
196+
197+ leftCon <- constrain env leftExpr (varN leftVar)
198+ rightCon <- constrain env rightExpr (varN rightVar)
199+
200+ leftVar' <- variable Flexible
201+ rightVar' <- variable Flexible
202+ answerVar <- variable Flexible
203+
204+ let opType = varN leftVar' ==> varN rightVar' ==> varN answerVar
205+
206+ return $
207+ ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $
208+ [ leftCon
209+ , rightCon
210+ , CInstance region (V.toString op) opType
211+ , CEqual (Error.BinopLeft op leftRegion) region (varN leftVar') (varN leftVar)
212+ , CEqual (Error.BinopRight op rightRegion) region (varN rightVar') (varN rightVar)
213+ , CEqual (Error.Binop op) region tipe (varN answerVar)
214+ ]
215+
216+
191217-- CONSTRAIN LISTS
192218
193219constrainList