16c3bc6 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix ExtraRecordField example

16c3bc6Phil Freeman11 years ago

examples/failing/ExtraRecordField.purs+1−2

compare with golang

unifiedsplit

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

1−-- @shouldFailWith PropertyIsMissing

1+-- @shouldFailWith AdditionalProperty

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

3module ExtraRecordField where

2module ExtraRecordField where

5import Prelude ((<>))

4import Prelude ((<>))

src/Language/PureScript/Errors.hs+10−4

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

126 | ExpectedType Type Kind

127 | IncorrectConstructorArity (Qualified ProperName)

128 | ExprDoesNotHaveType Expr Type

129− | PropertyIsMissing String Type

129+ | PropertyIsMissing String Expr

130+ | AdditionalProperty String Expr

130 | CannotApplyFunction Type Expr

131 | CannotApplyFunction Type Expr

131 | TypeSynonymInstance

132 | TypeSynonymInstance

132 | OrphanInstance Ident (Qualified ProperName) [Type]

133 | OrphanInstance Ident (Qualified ProperName) [Type]

@@ -263,6 +264,7 @@ errorCode em = case unwrapErrorMessage em of

263 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

264 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

264 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

265 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

265 PropertyIsMissing{} -> "PropertyIsMissing"

266 PropertyIsMissing{} -> "PropertyIsMissing"

267+ AdditionalProperty{} -> "AdditionalProperty"

266 CannotApplyFunction{} -> "CannotApplyFunction"

268 CannotApplyFunction{} -> "CannotApplyFunction"

267 TypeSynonymInstance -> "TypeSynonymInstance"

269 TypeSynonymInstance -> "TypeSynonymInstance"

268 OrphanInstance{} -> "OrphanInstance"

270 OrphanInstance{} -> "OrphanInstance"

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

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

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

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

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

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

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

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

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

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

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

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

359 gSimple other = pure other

360 gSimple other = pure other

@@ -617,11 +618,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

617 , line "does not have type"

618 , line "does not have type"

618 , indent $ typeAsBox ty

619 , indent $ typeAsBox ty

619 ]

620 ]

620− renderSimpleErrorMessage (PropertyIsMissing prop row) =

621+ renderSimpleErrorMessage (PropertyIsMissing prop expr) =

621 paras [ line "Row type"

622 paras [ line "Row type"

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

623+ , indent $ prettyPrintValue expr

623 , line $ "lacks required label " ++ show prop

624 , line $ "lacks required label " ++ show prop

624 ]

625 ]

626+ renderSimpleErrorMessage (AdditionalProperty prop expr) =

627+ paras [ line "Type of expression"

628+ , indent $ prettyPrintValue expr

629+ , line $ "contains additional label " ++ show prop

630+ ]

625 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

631 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

626 paras [ line "A function of type"

632 paras [ line "A function of type"

627 , indent $ typeAsBox fn

633 , indent $ typeAsBox fn

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

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

534 th' <- check th ty

535 el' <- check el ty

536 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

538 ensureNoDuplicateProperties ps

539− ps' <- checkProperties ps row False

539+ ps' <- checkProperties e ps row False

540 return $ TypedValue True (ObjectLiteral ps') t

541check' (TypeClassDictionaryConstructorApp name ps) t = do

542 ps' <- check' ps t

543 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

545 ensureNoDuplicateProperties ps

546 -- 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.

548 let (propsToCheck, rest) = rowToList row

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

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

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

552− ps' <- checkProperties ps row True

552+ ps' <- checkProperties e ps row True

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

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

555 rest <- fresh

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

586--

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

588--

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

589+checkProperties :: Expr -> [(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

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

591 go [] [] REmpty = return []

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

593 | lax = return []

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

595 return []

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

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

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

598+ | otherwise = throwError . errorMessage $ PropertyIsMissing p expr

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

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

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

601 case lookup p ts of

602 Nothing -> do

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

609 v' <- check v ty

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

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

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

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

613

614-- |

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