Merge pull request purescript#1567 from purescript/1315

paf31 · paf31 · commit 0fc5d6bd7441 · 2015-10-26T08:03:51.000-07:00
Fix purescript#1315
diff --git a/examples/failing/ExtraRecordField.purs b/examples/failing/ExtraRecordField.purs
@@ -1,5 +1,4 @@
--- @shouldFailWith PropertyIsMissing
--- TODO: Make this fail with a new error ExtraProperty instead.
+-- @shouldFailWith AdditionalProperty
 module ExtraRecordField where
 
 import Prelude ((<>))
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
@@ -125,7 +125,8 @@ data SimpleErrorMessage
   | ExpectedType Type Kind
   | IncorrectConstructorArity (Qualified ProperName)
   | ExprDoesNotHaveType Expr Type
-  | PropertyIsMissing String Type
+  | PropertyIsMissing String
+  | AdditionalProperty String
   | CannotApplyFunction Type Expr
   | TypeSynonymInstance
   | OrphanInstance Ident (Qualified ProperName) [Type]
@@ -260,6 +261,7 @@ errorCode em = case unwrapErrorMessage em of
   IncorrectConstructorArity{} -> "IncorrectConstructorArity"
   ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"
   PropertyIsMissing{} -> "PropertyIsMissing"
+  AdditionalProperty{} -> "AdditionalProperty"
   CannotApplyFunction{} -> "CannotApplyFunction"
   TypeSynonymInstance -> "TypeSynonymInstance"
   OrphanInstance{} -> "OrphanInstance"
@@ -350,7 +352,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
     gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
     gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
     gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
-    gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t
     gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e
     gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
     gSimple other = pure other
@@ -611,11 +612,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
             , line "does not have type"
             , indent $ typeAsBox ty
             ]
-    renderSimpleErrorMessage (PropertyIsMissing prop row) =
-      paras [ line "Row type"
-            , indent $ prettyPrintRowWith '(' ')' row
-            , line $ "lacks required 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
@@ -534,22 +534,22 @@ check' (IfThenElse cond th el) ty = do
   th' <- check th ty
   el' <- check el ty
   return $ TypedValue True (IfThenElse cond' th' el') ty
-check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
+check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
   ensureNoDuplicateProperties ps
-  ps' <- checkProperties ps row False
+  ps' <- checkProperties e ps row False
   return $ TypedValue True (ObjectLiteral ps') t
 check' (TypeClassDictionaryConstructorApp name ps) t = do
   ps' <- check' ps t
   return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
-check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
+check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
   ensureNoDuplicateProperties ps
   -- We need to be careful to avoid duplicate labels here.
-  -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.
+  -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.
   let (propsToCheck, rest) = rowToList row
       (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
   us <- zip (map fst removedProps) <$> replicateM (length ps) fresh
   obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))
-  ps' <- checkProperties ps row True
+  ps' <- checkProperties e ps row True
   return $ TypedValue True (ObjectUpdate obj' ps') t
 check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do
   rest <- fresh
@@ -586,17 +586,17 @@ check' val ty = do
 --
 -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
 --
-checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
-checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
+checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
+checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where
   go [] [] REmpty = return []
   go [] [] u@(TUnknown _)
     | lax = return []
     | otherwise = do u =?= REmpty
                      return []
   go [] [] Skolem{} | lax = return []
   go [] ((p, _): _) _ | lax = return []
-                      | otherwise = throwError . errorMessage $ PropertyIsMissing p row
-  go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row
+                      | 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
@@ -609,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
         v' <- check v ty
         ps'' <- go ps' (delete (p, ty) ts) r
         return $ (p, v') : ps''
-  go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)
+  go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row)
 
 -- |
 -- Check the type of a function application, rethrowing errors to provide a better error message
