16c3bc6 · rowtype-yoga/purescript-native

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

Fix ExtraRecordField example

commit16c3bc6f53184793c05666b590c6098214fc7f38 authorPhil Freeman <paf31@cantab.net> dateSun 25 Oct 2015, 16:48 (11 years ago) parent35afca6

3 files changed+21−16

compare with golang

unifiedsplit

examples/failing/ExtraRecordField.purs+1−2 src/Language/PureScript/Errors.hs+10−4 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 ((<>))

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

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

126126 | ExpectedType Type Kind

127127 | IncorrectConstructorArity (Qualified ProperName)

128128 | ExprDoesNotHaveType Expr Type

129− | PropertyIsMissing String Type

129+ | PropertyIsMissing String Expr

130+ | AdditionalProperty String Expr

130131 | CannotApplyFunction Type Expr

131132 | TypeSynonymInstance

132133 | OrphanInstance Ident (Qualified ProperName) [Type]

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

263264 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

264265 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

265266 PropertyIsMissing{} -> "PropertyIsMissing"

267+ AdditionalProperty{} -> "AdditionalProperty"

266268 CannotApplyFunction{} -> "CannotApplyFunction"

267269 TypeSynonymInstance -> "TypeSynonymInstance"

268270 OrphanInstance{} -> "OrphanInstance"

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

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

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

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

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

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

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

359360 gSimple other = pure other

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

617618 , line "does not have type"

618619 , indent $ typeAsBox ty

619620 ]

620− renderSimpleErrorMessage (PropertyIsMissing prop row) =

621+ renderSimpleErrorMessage (PropertyIsMissing prop expr) =

621622 paras [ line "Row type"

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

623+ , indent $ prettyPrintValue expr

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

624625 ]

626+ renderSimpleErrorMessage (AdditionalProperty prop expr) =

627+ paras [ line "Type of expression"

628+ , indent $ prettyPrintValue expr

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

630+ ]

625631 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

626632 paras [ line "A function of type"

627633 , indent $ typeAsBox fn

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 expr

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

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