git.iko.soy/elk
on master help sign in
Improve error message when type annotation does not match defined value
304d4f3Evan Czaplicki
src/Reporting/Error/Type.hs+6
compare with master
unifiedsplit
@@ -39,6 +39,7 @@ data Hint
39 | Binop Var.Canonical
39 | Binop Var.Canonical
40 | BadArgument Region.Region
40 | BadArgument Region.Region
41 | ExtraArgument Region.Region
41 | ExtraArgument Region.Region
42+ | BadTypeAnnotation String
42
43
43
44
44data Note
45data Note
@@ -168,6 +169,11 @@ hintToString hint =
168 ++ "Maybe you provided an extra argument?"
169 ++ "Maybe you provided an extra argument?"
169 )
170 )
170
171
172+ BadTypeAnnotation name ->
173+ ( Nothing
174+ , "The type annotation for '" ++ name ++ "' does not match its definition."
175+ )
176+
171
177
172prettyOperator :: Var.Canonical -> String
178prettyOperator :: Var.Canonical -> String
173prettyOperator (Var.Canonical _ opName) =
179prettyOperator (Var.Canonical _ opName) =
src/Type/Constrain/Expression.hs+11−7
@@ -416,12 +416,12 @@ data Info = Info
416
416
417
417
418constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
418constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
419−constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =
419+constrainDef env info (Canonical.Definition (A.A region pattern) expr maybeTipe) =
420 let qs = [] -- should come from the def, but I'm not sure what would live there...
420 let qs = [] -- should come from the def, but I'm not sure what would live there...
421 in
421 in
422 case (pattern, maybeTipe) of
422 case (pattern, maybeTipe) of
423 (P.Var name, Just tipe) ->
423 (P.Var name, Just tipe) ->
424− constrainAnnotatedDef env info qs name expr tipe
424+ constrainAnnotatedDef env info qs region name expr tipe
425
425
426 (P.Var name, Nothing) ->
426 (P.Var name, Nothing) ->
427 constrainUnannotatedDef env info qs name expr
427 constrainUnannotatedDef env info qs name expr
@@ -433,11 +433,12 @@ constrainAnnotatedDef
433 :: Env.Environment
433 :: Env.Environment
434 -> Info
434 -> Info
435 -> [String]
435 -> [String]
436+ -> R.Region
436 -> String
437 -> String
437 -> Canonical.Expr
438 -> Canonical.Expr
438 -> ST.Canonical
439 -> ST.Canonical
439 -> IO Info
440 -> IO Info
440−constrainAnnotatedDef env info qs name expr tipe =
441+constrainAnnotatedDef env info qs region name expr tipe =
441 do -- Some mistake may be happening here. Currently, qs is always [].
442 do -- Some mistake may be happening here. Currently, qs is always [].
442 rigidVars <- Monad.forM qs (\_ -> variable Rigid)
443 rigidVars <- Monad.forM qs (\_ -> variable Rigid)
443
444
@@ -457,11 +458,14 @@ constrainAnnotatedDef env info qs name expr tipe =
457 , header = Map.singleton name typ
458 , header = Map.singleton name typ
458 }
459 }
459
460
461+ var <- variable Flexible
460− c <- constrain env' expr typ
462+ defCon <- constrain env' expr (varN var)
463+ let annCon =
464+ CEqual (Error.BadTypeAnnotation name) region typ (varN var)
461
465
462 return $ info
466 return $ info
463 { iSchemes = scheme : iSchemes info
467 { iSchemes = scheme : iSchemes info
464− , iC1 = fl rigidVars c /\ iC1 info
468+ , iC1 = iC1 info /\ ex [var] (defCon /\ fl rigidVars annCon)
465 }
469 }
466
470
467
471
@@ -484,11 +488,11 @@ constrainUnannotatedDef env info qs name expr =
484
488
485 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
489 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
486
490
487− c <- constrain env' expr tipe
491+ con <- constrain env' expr tipe
488
492
489 return $ info
493 return $ info
490 { iRigid = rigidVars ++ iRigid info
494 { iRigid = rigidVars ++ iRigid info
491 , iFlex = v : iFlex info
495 , iFlex = v : iFlex info
492 , iHeaders = Map.insert name tipe (iHeaders info)
496 , iHeaders = Map.insert name tipe (iHeaders info)
493− , iC2 = c /\ iC2 info
497+ , iC2 = con /\ iC2 info
494 }
498 }