Fix #1577, fix #1130

purescript · Oct 29, 2015 · c059120 · c059120
1 parent a70e397
commit c059120
Show file tree

Hide file tree

Showing 2 changed files with 10 additions and 5 deletions.
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -156,6 +156,7 @@ data ErrorMessageHint
   | ErrorCheckingAccessor Expr String
   | ErrorCheckingType Expr Type
   | ErrorCheckingKind Type
+  | ErrorCheckingGuard
   | ErrorInferringType Expr
   | ErrorInApplication Expr Type Expr
   | ErrorInDataConstructor ProperName
@@ -530,15 +531,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
                                           , indent $ prettyPrintValue expr
                                           ]) binding
     renderSimpleErrorMessage (TypesDoNotUnify t1 t2)
-      = paras [ line "Could not match expected type"
+      = paras [ line "Could not match type"
               , indent $ typeAsBox t1
-              , line "with actual type"
+              , line "with type"
               , indent $ typeAsBox t2
               ]
     renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
-      paras [ line "Could not match expected kind"
+      paras [ line "Could not match kind"
             , indent $ line $ prettyPrintKind k1
-            , line "with actual kind"
+            , line "with kind"
             , indent $ line $ prettyPrintKind k2
             ]
     renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) =
@@ -730,6 +731,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
                                  , typeAsBox ty
                                  ]
             ]
+    renderHint ErrorCheckingGuard detail =
+      paras [ detail
+            , line "while checking the type of a guard clause"
+            ]
     renderHint (ErrorInferringType expr) detail =
       paras [ detail
             , Box.hsep 1 Box.top [ line "while inferring the type of"

diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -418,7 +418,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do
       case result of
         Left gs -> do
           gs' <- forM gs $ \(grd, val) -> do
-            grd' <- check grd tyBoolean
+            grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean
             val' <- TypedValue True <$> check val ret <*> pure ret
             return (grd', val')
           return $ Left gs'