Fix purescript#1315

paf31 · paf31 · commit 0b8a09f58a16 · 2015-10-25T17:34:04.000-07:00
diff --git a/examples/failing/MissingRecordField.purs b/examples/failing/MissingRecordField.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith TypesDoNotUnify
--- TODO: Update type checker to make this fail with PropertyIsMissing instead. 
+-- @shouldFailWith PropertyIsMissing
 module MissingRecordField where
 
 import Prelude ((>))
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -126,8 +126,8 @@ data SimpleErrorMessage
   | ExpectedType Type Kind
   | IncorrectConstructorArity (Qualified ProperName)
   | ExprDoesNotHaveType Expr Type
-  | PropertyIsMissing String Expr
-  | AdditionalProperty String Expr
+  | PropertyIsMissing String
+  | AdditionalProperty String
   | CannotApplyFunction Type Expr
   | TypeSynonymInstance
   | OrphanInstance Ident (Qualified ProperName) [Type]
@@ -618,16 +618,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
             , line "does not have type"
             , indent $ typeAsBox ty
             ]
-    renderSimpleErrorMessage (PropertyIsMissing prop expr) =
-      paras [ line "Row type"
-            , indent $ prettyPrintValue expr
-            , line $ "lacks required label " ++ show prop
-            ]
-    renderSimpleErrorMessage (AdditionalProperty prop expr) =
-      paras [ line "Type of expression"
-            , indent $ prettyPrintValue expr
-            , line $ "contains additional label " ++ show prop
-            ]
+    renderSimpleErrorMessage (PropertyIsMissing prop) =
+      line $ "Type of expression lacks required label " ++ show prop ++ "."
+    renderSimpleErrorMessage (AdditionalProperty prop) =
+      line $ "Type of expression contains additional label " ++ show prop ++ "."
     renderSimpleErrorMessage (CannotApplyFunction fn arg) =
       paras [ line "A function of type"
             , indent $ typeAsBox fn
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -21,6 +21,7 @@ import Data.List (sortBy)
 import Data.Ord (comparing)
 
 import Control.Monad.Unify
+import Control.Monad.Error.Class (throwError)
 
 import Language.PureScript.Crash
 import Language.PureScript.AST
@@ -77,10 +78,17 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject
     | p1 == p2 = do _ <- subsumes Nothing ty1 ty2
                     go ts1 ts2 r1' r2'
     | p1 < p2 = do rest <- fresh
-                   r2' =?= RCons p1 ty1 rest
+                   -- What happens next is a bit of a hack.
+                   -- TODO: in the new type checker, object properties will probably be restricted to being monotypes
+                   -- in which case, this branch of the subsumes function should not even be necessary.
+                   case r2' of
+                     REmpty -> throwError . errorMessage $ AdditionalProperty p1
+                     _ -> r2' =?= RCons p1 ty1 rest
                    go ts1 ((p2, ty2) : ts2) r1' rest
     | otherwise = do rest <- fresh
-                     r1' =?= RCons p2 ty2 rest
+                     case r1' of
+                       REmpty -> throwError . errorMessage $ PropertyIsMissing p2
+                       _ -> r1' =?= RCons p2 ty2 rest
                      go ((p1, ty1) : ts1) ts2 rest r2'
 subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1
 subsumes' val ty1 ty2 = do
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
@@ -595,8 +595,8 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh
                      return []
   go [] [] Skolem{} | lax = return []
   go [] ((p, _): _) _ | lax = return []
-                      | otherwise = throwError . errorMessage $ PropertyIsMissing p expr
-  go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p expr
+                      | otherwise = throwError . errorMessage $ PropertyIsMissing p
+  go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p
   go ((p,v):ps') ts r =
     case lookup p ts of
       Nothing -> do
