0fc5d6b · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Merge pull request #1567 from purescript/1315

Fix #1315

commit0fc5d6bd744129ff8cd1bf5e64134ce88461d4d2 authorPhil Freeman <paf31@cantab.net> dateMon 26 Oct 2015, 08:03 (11 years ago) parenta85e061 0b8a09f

5 files changed+29−23

compare with golang

unifiedsplit

examples/failing/ExtraRecordField.purs+1−2 examples/failing/MissingRecordField.purs+1−2 src/Language/PureScript/Errors.hs+7−7 src/Language/PureScript/TypeChecker/Subsumption.hs+10−2 src/Language/PureScript/TypeChecker/Types.hs+10−10

examples/failing/ExtraRecordField.purs+1−2

@@ -1,5 +1,4 @@

1−-- @shouldFailWith PropertyIsMissing

2−-- TODO: Make this fail with a new error ExtraProperty instead.

1+-- @shouldFailWith AdditionalProperty

32module ExtraRecordField where

54import Prelude ((<>))

examples/failing/MissingRecordField.purs+1−2

@@ -1,5 +1,4 @@

1−-- @shouldFailWith TypesDoNotUnify

2−-- TODO: Update type checker to make this fail with PropertyIsMissing instead.

1+-- @shouldFailWith PropertyIsMissing

32module MissingRecordField where

54import Prelude ((>))

src/Language/PureScript/Errors.hs+7−7

@@ -125,7 +125,8 @@ data SimpleErrorMessage

125125 | ExpectedType Type Kind

126126 | IncorrectConstructorArity (Qualified ProperName)

127127 | ExprDoesNotHaveType Expr Type

128− | PropertyIsMissing String Type

128+ | PropertyIsMissing String

129+ | AdditionalProperty String

129130 | CannotApplyFunction Type Expr

130131 | TypeSynonymInstance

131132 | OrphanInstance Ident (Qualified ProperName) [Type]

@@ -260,6 +261,7 @@ errorCode em = case unwrapErrorMessage em of

260261 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

261262 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

262263 PropertyIsMissing{} -> "PropertyIsMissing"

264+ AdditionalProperty{} -> "AdditionalProperty"

263265 CannotApplyFunction{} -> "CannotApplyFunction"

264266 TypeSynonymInstance -> "TypeSynonymInstance"

265267 OrphanInstance{} -> "OrphanInstance"

@@ -350,7 +352,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

350352 gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

351353 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

352354 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

353− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t

354355 gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

355356 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

356357 gSimple other = pure other

@@ -611,11 +612,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

611612 , line "does not have type"

612613 , indent $ typeAsBox ty

613614 ]

614− renderSimpleErrorMessage (PropertyIsMissing prop row) =

615− paras [ line "Row type"

616− , indent $ prettyPrintRowWith '(' ')' row

617− , line $ "lacks required label " ++ show prop

618− ]

615+ renderSimpleErrorMessage (PropertyIsMissing prop) =

616+ line $ "Type of expression lacks required label " ++ show prop ++ "."

617+ renderSimpleErrorMessage (AdditionalProperty prop) =

618+ line $ "Type of expression contains additional label " ++ show prop ++ "."

619619 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

620620 paras [ line "A function of type"

621621 , indent $ typeAsBox fn

src/Language/PureScript/TypeChecker/Subsumption.hs+10−2

@@ -21,6 +21,7 @@ import Data.List (sortBy)

2121import Data.Ord (comparing)

2222

2323import Control.Monad.Unify

24+import Control.Monad.Error.Class (throwError)

2425

2526import Language.PureScript.Crash

2627import Language.PureScript.AST

@@ -77,10 +78,17 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject

7778 | p1 == p2 = do _ <- subsumes Nothing ty1 ty2

7879 go ts1 ts2 r1' r2'

7980 | p1 < p2 = do rest <- fresh

80− r2' =?= RCons p1 ty1 rest

81+ -- What happens next is a bit of a hack.

82+ -- TODO: in the new type checker, object properties will probably be restricted to being monotypes

83+ -- in which case, this branch of the subsumes function should not even be necessary.

84+ case r2' of

85+ REmpty -> throwError . errorMessage $ AdditionalProperty p1

86+ _ -> r2' =?= RCons p1 ty1 rest

8187 go ts1 ((p2, ty2) : ts2) r1' rest

8288 | otherwise = do rest <- fresh

83− r1' =?= RCons p2 ty2 rest

89+ case r1' of

90+ REmpty -> throwError . errorMessage $ PropertyIsMissing p2

91+ _ -> r1' =?= RCons p2 ty2 rest

8492 go ((p1, ty1) : ts1) ts2 rest r2'

8593subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1

8694subsumes' val ty1 ty2 = do

src/Language/PureScript/TypeChecker/Types.hs+10−10

@@ -534,22 +534,22 @@ check' (IfThenElse cond th el) ty = do

534534 th' <- check th ty

535535 el' <- check el ty

536536 return $ TypedValue True (IfThenElse cond' th' el') ty

537−check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

537+check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

538538 ensureNoDuplicateProperties ps

539− ps' <- checkProperties ps row False

539+ ps' <- checkProperties e ps row False

540540 return $ TypedValue True (ObjectLiteral ps') t

541541check' (TypeClassDictionaryConstructorApp name ps) t = do

542542 ps' <- check' ps t

543543 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

544−check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

544+check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

545545 ensureNoDuplicateProperties ps

546546 -- We need to be careful to avoid duplicate labels here.

547− -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.

547+ -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns.

548548 let (propsToCheck, rest) = rowToList row

549549 (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck

550550 us <- zip (map fst removedProps) <$> replicateM (length ps) fresh

551551 obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))

552− ps' <- checkProperties ps row True

552+ ps' <- checkProperties e ps row True

553553 return $ TypedValue True (ObjectUpdate obj' ps') t

554554check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do

555555 rest <- fresh

@@ -586,8 +586,8 @@ check' val ty = do

586586--

587587-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

588588--

589−checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

590−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

589+checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

590+checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where

591591 go [] [] REmpty = return []

592592 go [] [] u@(TUnknown _)

593593 | lax = return []

@@ -595,8 +595,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

595595 return []

596596 go [] [] Skolem{} | lax = return []

597597 go [] ((p, _): _) _ | lax = return []

598− | otherwise = throwError . errorMessage $ PropertyIsMissing p row

599− go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row

598+ | otherwise = throwError . errorMessage $ PropertyIsMissing p

599+ go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p

600600 go ((p,v):ps') ts r =

601601 case lookup p ts of

602602 Nothing -> do

@@ -609,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

609609 v' <- check v ty

610610 ps'' <- go ps' (delete (p, ty) ts) r

611611 return $ (p, v') : ps''

612− go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row)

612+ go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row)

613613

614614-- |

615615-- Check the type of a function application, rethrowing errors to provide a better error message