0fc5d6b · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1567 from purescript/1315

0fc5d6bPhil 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 ((<>))

examples/failing/MissingRecordField.purs+1−2

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

1−-- @shouldFailWith TypesDoNotUnify

1+-- @shouldFailWith PropertyIsMissing

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

3module MissingRecordField where

2module MissingRecordField where

5import Prelude ((>))

4import Prelude ((>))

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

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

125 | ExpectedType Type Kind

126 | IncorrectConstructorArity (Qualified ProperName)

127 | ExprDoesNotHaveType Expr Type

128− | PropertyIsMissing String Type

128+ | PropertyIsMissing String

129+ | AdditionalProperty String

129 | CannotApplyFunction Type Expr

130 | CannotApplyFunction Type Expr

130 | TypeSynonymInstance

131 | TypeSynonymInstance

131 | OrphanInstance Ident (Qualified ProperName) [Type]

132 | OrphanInstance Ident (Qualified ProperName) [Type]

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

260 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

261 IncorrectConstructorArity{} -> "IncorrectConstructorArity"

261 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

262 ExprDoesNotHaveType{} -> "ExprDoesNotHaveType"

262 PropertyIsMissing{} -> "PropertyIsMissing"

263 PropertyIsMissing{} -> "PropertyIsMissing"

264+ AdditionalProperty{} -> "AdditionalProperty"

263 CannotApplyFunction{} -> "CannotApplyFunction"

265 CannotApplyFunction{} -> "CannotApplyFunction"

264 TypeSynonymInstance -> "TypeSynonymInstance"

266 TypeSynonymInstance -> "TypeSynonymInstance"

265 OrphanInstance{} -> "OrphanInstance"

267 OrphanInstance{} -> "OrphanInstance"

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

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

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

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

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

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

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

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

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

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

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

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

356 gSimple other = pure other

357 gSimple other = pure other

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

611 , line "does not have type"

612 , line "does not have type"

612 , indent $ typeAsBox ty

613 , indent $ typeAsBox ty

613 ]

614 ]

614− renderSimpleErrorMessage (PropertyIsMissing prop row) =

615+ renderSimpleErrorMessage (PropertyIsMissing prop) =

615− paras [ line "Row type"

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

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

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

618− ]

617+ renderSimpleErrorMessage (AdditionalProperty prop) =

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

619 renderSimpleErrorMessage (CannotApplyFunction fn arg) =

620 paras [ line "A function of type"

621 , indent $ typeAsBox fn

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

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

21import Data.Ord (comparing)

23import Control.Monad.Unify

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

25import Language.PureScript.Crash

26import Language.PureScript.Crash

26import Language.PureScript.AST

27import Language.PureScript.AST

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

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

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

78 go ts1 ts2 r1' r2'

79 go ts1 ts2 r1' r2'

79 | p1 < p2 = do rest <- fresh

80 | p1 < p2 = do rest <- fresh

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

80− r2' =?= RCons p1 ty1 rest

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

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

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

82 | otherwise = do rest <- fresh

88 | otherwise = do rest <- fresh

89+ case r1' of

90+ REmpty -> throwError . errorMessage $ PropertyIsMissing p2

83− r1' =?= RCons p2 ty2 rest

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

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

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

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

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

86subsumes' val ty1 ty2 = do

94subsumes' val ty1 ty2 = do

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

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

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

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