74c2628 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #315 and fix #316

74c2628Phil Freeman13 years ago

examples/passing/LiberalTypeSynonyms.pursnew file+19

compare with golang

unifiedsplit

@@ -0,0 +1,19 @@

1+module Main where

3+type Reader = (->) String

5+foo :: Reader String

6+foo s = s

8+type AndFoo r = (foo :: String | r)

10+getFoo :: forall r. Prim.Object (AndFoo r) -> String

11+getFoo o = o.foo

12+

13+type F r = { | r } -> { | r }

14+

15+f :: (forall r. F r) -> String

16+f g = case g { x: "Hello" } of

17+ { x = x } -> x

18+

19+main = Debug.Trace.trace "Done"

examples/passing/STArray.purs+6−6

@@ -11,14 +11,14 @@ test = runSTArray (do

11 pokeSTArray a 1 2

12 return a)

14−fromTo' lo hi _ arr | lo > hi = return arr

15−fromTo' lo hi i arr = do

16− pokeSTArray arr i lo

17− fromTo' (lo + 1) hi (i + 1) arr

18−

19fromTo lo hi = runSTArray (do

14fromTo lo hi = runSTArray (do

20 arr <- newSTArray (hi - lo + 1) 0

15 arr <- newSTArray (hi - lo + 1) 0

16+ (let

17+ go lo hi _ arr | lo > hi = return arr

18+ go lo hi i arr = do

19+ pokeSTArray arr i lo

20+ go (lo + 1) hi (i + 1) arr

21− fromTo' lo hi 0 arr)

21+ in go lo hi 0 arr))

23main = do

24 let t1 = runPure (fromTo 10 20)

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -193,7 +193,7 @@ runtimeTypeChecks arg ty =

193 argumentCheck val t | t == tyString = [typeCheck val "string"]

194 argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]

195 argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]

196− argumentCheck val (Object row) =

196+ argumentCheck val (TypeApp t row) | t == tyObject =

197 let

198 (pairs, _) = rowToList row

199 in

src/Language/PureScript/Environment.hs+7

@@ -171,6 +171,12 @@ tyBoolean = primTy "Boolean"

171tyArray :: Type

172tyArray = primTy "Array"

173

174+-- |

175+-- Type constructor for objects

176+--

177+tyObject :: Type

178+tyObject = primTy "Object"

179+

174-- |

180-- |

175-- Smart constructor for function types

181-- Smart constructor for function types

176--

182--

@@ -183,6 +189,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)

183primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

189primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)

184primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))

190primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))

185 , (primName "Array" , (FunKind Star Star, ExternData))

191 , (primName "Array" , (FunKind Star Star, ExternData))

192+ , (primName "Object" , (FunKind (Row Star) Star, ExternData))

186 , (primName "String" , (Star, ExternData))

193 , (primName "String" , (Star, ExternData))

187 , (primName "Number" , (Star, ExternData))

194 , (primName "Number" , (Star, ExternData))

188 , (primName "Boolean" , (Star, ExternData)) ]

195 , (primName "Boolean" , (Star, ExternData)) ]

src/Language/PureScript/Parser/Types.hs+1−1

@@ -49,7 +49,7 @@ parseFunction :: P.Parsec String ParseState Type

49parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction

51parseObject :: P.Parsec String ParseState Type

52−parseObject = braces $ Object <$> parseRow False

52+parseObject = braces $ TypeApp tyObject <$> parseRow False

54parseTypeVariable :: P.Parsec String ParseState Type

55parseTypeVariable = do

src/Language/PureScript/Pretty/Types.hs+3−5

@@ -34,8 +34,8 @@ import Language.PureScript.Environment

34typeLiterals :: Pattern () Type String

35typeLiterals = mkPattern match

36 where

37− match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

38 match (TypeVar var) = Just var

37 match (TypeVar var) = Just var

38+ match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

39 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

40 match (TypeConstructor ctor) = Just $ show ctor

41 match (TUnknown (Unknown u)) = Just $ 'u' : show u

@@ -56,10 +56,7 @@ prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs

56 nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty

57 tailToPs :: Type -> String

58 tailToPs REmpty = ""

59− tailToPs (TUnknown (Unknown u)) = " | u" ++ show u

59+ tailToPs other = " | " ++ prettyPrintType other

60− tailToPs (TypeVar var) = " | " ++ var

61− tailToPs (Skolem s _) = " | s" ++ show s

62− tailToPs _ = error "Invalid row tail"

63 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

60 toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

64 toList tys (RCons name ty row) = toList ((name, ty):tys) row

61 toList tys (RCons name ty row) = toList ((name, ty):tys) row

65 toList tys r = (tys, r)

62 toList tys r = (tys, r)

@@ -81,6 +78,7 @@ insertPlaceholders = everywhere' (mkT convertForAlls) . everywhere (mkT convert)

81 where

78 where

82 convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

79 convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret

83 convert (TypeApp a el) | a == tyArray = PrettyPrintArray el

80 convert (TypeApp a el) | a == tyArray = PrettyPrintArray el

81+ convert (TypeApp o r) | o == tyObject = PrettyPrintObject r

84 convert other = other

82 convert other = other

85 convertForAlls (ForAll ident ty _) = go [ident] ty

83 convertForAlls (ForAll ident ty _) = go [ident] ty

86 where

84 where

src/Language/PureScript/Sugar/TypeClasses.hs+4−1

@@ -107,7 +107,7 @@ memberToNameAndType _ = error "Invalid declaration in type class definition"

107

108typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

109typeClassDictionaryDeclaration name args members =

110− TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))

110+ TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty))

111

112typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

113typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

@@ -133,6 +133,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

133 foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))

134 )

135 where

136+ unit :: Type

137+ unit = TypeApp tyObject REmpty

138+

136 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

139 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

137 memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do

140 memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do

138 memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'

141 memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'

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

@@ -107,7 +107,7 @@ typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declar

107typeCheckAll _ _ [] = return []

108typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do

109 rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

110− ctorKind <- kindsOf moduleName name args (concatMap snd dctors)

110+ ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)

111 addDataType moduleName name args dctors ctorKind

112 ds <- typeCheckAll mainModuleName moduleName rest

113 return $ d : ds

@@ -129,7 +129,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

129 toDataDecl _ = Nothing

130typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

131 rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

132− kind <- kindsOf moduleName name args [ty]

132+ kind <- kindsOf False moduleName name args [ty]

133 addTypeSynonym moduleName name args ty kind

134 ds <- typeCheckAll mainModuleName moduleName rest

135 return $ d : ds

src/Language/PureScript/TypeChecker/Kinds.hs+13−13

@@ -67,13 +67,13 @@ kindOf _ ty =

67-- |

68-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

69--

70−kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

70+kindsOf :: Bool -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

71−kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do

71+kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do

72 tyCon <- fresh

73 kargs <- replicateM (length args) fresh

74 let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs

75 bindLocalTypeVariables moduleName dict $

76− solveTypes ts kargs tyCon

76+ solveTypes isData ts kargs tyCon

77 where

78 tidyUp (k, sub) = starIfUnknown $ sub $? k

@@ -92,12 +92,12 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

92 kargs <- replicateM (length args) fresh

93 let argDict = zip (map ProperName args) kargs

94 bindLocalTypeVariables moduleName argDict $

95− solveTypes ts kargs tyCon) tyCons tys

95+ solveTypes True ts kargs tyCon) tyCons tys

96 syn_ks <- zipWithM (\synVar (_, args, ty) -> do

97 kargs <- replicateM (length args) fresh

98 let argDict = zip (map ProperName args) kargs

99 bindLocalTypeVariables moduleName argDict $

100− solveTypes [ty] kargs synVar) synVars syns

100+ solveTypes False [ty] kargs synVar) synVars syns

101 return (syn_ks, data_ks)

102 where

103 tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)

@@ -105,11 +105,14 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

105-- |

106-- Solve the set of kind constraints associated with the data constructors for a type constructor

107--

108−solveTypes :: [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind

108+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind

109−solveTypes ts kargs tyCon = do

109+solveTypes isData ts kargs tyCon = do

110 ks <- mapM infer ts

111+ when isData $ do

111− tyCon =?= foldr FunKind Star kargs

112+ tyCon =?= foldr FunKind Star kargs

112− forM_ ks $ \k -> k =?= Star

113+ forM_ ks $ \k -> k =?= Star

114+ when (not isData) $ do

115+ tyCon =?= foldr FunKind (head ks) kargs

113 return tyCon

116 return tyCon

114

117

115-- |

118-- |

@@ -117,6 +120,7 @@ solveTypes ts kargs tyCon = do

117--

120--

118starIfUnknown :: Kind -> Kind

121starIfUnknown :: Kind -> Kind

119starIfUnknown (KUnknown _) = Star

122starIfUnknown (KUnknown _) = Star

123+starIfUnknown (Row k) = Row (starIfUnknown k)

120starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

124starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

121starIfUnknown k = k

125starIfUnknown k = k

122

126

@@ -124,10 +128,6 @@ starIfUnknown k = k

124-- Infer a kind for a type

128-- Infer a kind for a type

125--

129--

126infer :: Type -> UnifyT Kind Check Kind

130infer :: Type -> UnifyT Kind Check Kind

127−infer (Object row) = do

128− k <- infer row

129− k =?= Row Star

130− return Star

131infer (TypeVar v) = do

132 Just moduleName <- checkCurrentModule <$> get

133 UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

src/Language/PureScript/TypeChecker/Types.hs+28−16

@@ -107,7 +107,6 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

107 sk `unifyTypes` ty2

108 unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"

109 unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

110− unifyTypes' (Object row1) (Object row2) = row1 =?= row2

111 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

110 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

112 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

111 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =

113 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

112 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)

@@ -475,6 +474,12 @@ expandTypeSynonym name args = do

475 env <- getEnv

474 env <- getEnv

476 either throwError return $ expandTypeSynonym' env name args

475 either throwError return $ expandTypeSynonym' env name args

477

476

477+expandAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Type -> m Type

478+expandAllTypeSynonyms = everywhereM' (mkM go)

479+ where

480+ go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

481+ go other = return other

482+

478-- |

483-- |

479-- Ensure a set of property names and value does not contain duplicate labels

484-- Ensure a set of property names and value does not contain duplicate labels

480--

485--

@@ -503,7 +508,7 @@ infer' (ObjectLiteral ps) = do

503 ensureNoDuplicateProperties ps

508 ensureNoDuplicateProperties ps

504 ts <- mapM (infer . snd) ps

509 ts <- mapM (infer . snd) ps

505 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

510 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

506− ty = Object $ rowFromList (fields, REmpty)

511+ ty = TypeApp tyObject $ rowFromList (fields, REmpty)

507 return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

512 return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

508infer' (ObjectUpdate o ps) = do

513infer' (ObjectUpdate o ps) = do

509 ensureNoDuplicateProperties ps

514 ensureNoDuplicateProperties ps

@@ -511,9 +516,9 @@ infer' (ObjectUpdate o ps) = do

511 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps

516 newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps

512 let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals

517 let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals

513 oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh

518 oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh

514− let oldTy = Object $ rowFromList (oldTys, row)

519+ let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)

515 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

520 o' <- TypedValue True <$> check o oldTy <*> pure oldTy

516− return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

521+ return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)

517infer' (Accessor prop val) = do

522infer' (Accessor prop val) = do

518 typed@(TypedValue _ _ objTy) <- infer val

523 typed@(TypedValue _ _ objTy) <- infer val

519 propTy <- inferProperty objTy prop

524 propTy <- inferProperty objTy prop

@@ -521,7 +526,7 @@ infer' (Accessor prop val) = do

521 Nothing -> do

526 Nothing -> do

522 field <- fresh

527 field <- fresh

523 rest <- fresh

528 rest <- fresh

524− _ <- subsumes Nothing objTy (Object (RCons prop field rest))

529+ _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))

525 return $ TypedValue True (Accessor prop typed) field

530 return $ TypedValue True (Accessor prop typed) field

526 Just ty -> return $ TypedValue True (Accessor prop typed) ty

531 Just ty -> return $ TypedValue True (Accessor prop typed) ty

527infer' (Abs (Left arg) ret) = do

532infer' (Abs (Left arg) ret) = do

@@ -593,7 +598,7 @@ inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"

593-- Infer the type of a property inside a record with a given type

598-- Infer the type of a property inside a record with a given type

594--

599--

595inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)

600inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)

596−inferProperty (Object row) prop = do

601+inferProperty (TypeApp obj row) prop | obj == tyObject = do

597 let (props, _) = rowToList row

602 let (props, _) = rowToList row

598 return $ lookup prop props

603 return $ lookup prop props

599inferProperty (SaturatedTypeSynonym name args) prop = do

604inferProperty (SaturatedTypeSynonym name args) prop = do

@@ -632,7 +637,7 @@ inferBinder val (ObjectBinder props) = do

632 row <- fresh

637 row <- fresh

633 rest <- fresh

638 rest <- fresh

634 m1 <- inferRowProperties row rest props

639 m1 <- inferRowProperties row rest props

635− val =?= Object row

640+ val =?= TypeApp tyObject row

636 return m1

641 return m1

637 where

642 where

638 inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)

643 inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)

@@ -736,8 +741,7 @@ check' val t@(ConstrainedType constraints ty) = do

736 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

741 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

737check' val (SaturatedTypeSynonym name args) = do

742check' val (SaturatedTypeSynonym name args) = do

738 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

743 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

739− val' <- check val ty

744+ check val ty

740− return $ TypedValue True val' ty

741check' val u@(TUnknown _) = do

745check' val u@(TUnknown _) = do

742 val'@(TypedValue _ _ ty) <- infer val

746 val'@(TypedValue _ _ ty) <- infer val

743 -- Don't unify an unknown with an inferred polytype

747 -- Don't unify an unknown with an inferred polytype

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

792 th' <- check th ty

796 th' <- check th ty

793 el' <- check el ty

797 el' <- check el ty

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

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

795−check' (ObjectLiteral ps) t@(Object row) = do

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

796 ensureNoDuplicateProperties ps

800 ensureNoDuplicateProperties ps

797 ps' <- checkProperties ps row False

801 ps' <- checkProperties ps row False

798 return $ TypedValue True (ObjectLiteral ps') t

802 return $ TypedValue True (ObjectLiteral ps') t

799−check' (ObjectUpdate obj ps) t@(Object row) = do

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

800 ensureNoDuplicateProperties ps

804 ensureNoDuplicateProperties ps

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

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

802 let (propsToCheck, rest) = rowToList row

806 let (propsToCheck, rest) = rowToList row

803 propsToRemove = map fst ps

807 propsToRemove = map fst ps

804 remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck

808 remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck

805− obj' <- check obj (Object (rowFromList (us ++ remainingProps, rest)))

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

806 ps' <- checkProperties ps row True

810 ps' <- checkProperties ps row True

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

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

808check' (Accessor prop val) ty = do

812check' (Accessor prop val) ty = do

809 rest <- fresh

813 rest <- fresh

810− val' <- check val (Object (RCons prop ty rest))

814+ val' <- check val (TypeApp tyObject (RCons prop ty rest))

811 return $ TypedValue True (Accessor prop val') ty

815 return $ TypedValue True (Accessor prop val') ty

812check' (Constructor c) ty = do

816check' (Constructor c) ty = do

813 env <- getEnv

817 env <- getEnv

@@ -820,8 +824,16 @@ check' (Constructor c) ty = do

820check' (Let ds val) ty = do

824check' (Let ds val) ty = do

821 (ds', val') <- inferLetBinding [] ds val (flip check ty)

825 (ds', val') <- inferLetBinding [] ds val (flip check ty)

822 return $ TypedValue True (Let ds' val') ty

826 return $ TypedValue True (Let ds' val') ty

827+check' val ty | containsTypeSynonyms ty = do

828+ ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

829+ check val ty'

823check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

830check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

824

831

832+containsTypeSynonyms :: Type -> Bool

833+containsTypeSynonyms = everything (||) (mkQ False go) where

834+ go (SaturatedTypeSynonym _ _) = True

835+ go _ = False

836+

825-- |

837-- |

826-- Check the type of a collection of named record fields

838-- Check the type of a collection of named record fields

827--

839--

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

854 v' <- check v ty

866 v' <- check v ty

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

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

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

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

857− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

869+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (TypeApp tyObject row)

858

870

859-- |

871-- |

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

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

@@ -939,7 +951,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

939 dicts <- getTypeClassDictionaries

951 dicts <- getTypeClassDictionaries

940 _ <- subsumes' Nothing ty1 ty2

952 _ <- subsumes' Nothing ty1 ty2

941 return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)

953 return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)

942−subsumes' val (Object r1) (Object r2) = do

954+subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do

943 let

955 let

944 (ts1, r1') = rowToList r1

956 (ts1, r1') = rowToList r1

945 (ts2, r2') = rowToList r2

957 (ts2, r2') = rowToList r2

@@ -959,7 +971,7 @@ subsumes' val (Object r1) (Object r2) = do

959 | otherwise = do rest <- fresh

971 | otherwise = do rest <- fresh

960 r1' =?= RCons p2 ty2 rest

972 r1' =?= RCons p2 ty2 rest

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

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

962−subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

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

963subsumes' val ty1 ty2 = do

975subsumes' val ty1 ty2 = do

964 ty1 =?= ty2

976 ty1 =?= ty2

965 return val

977 return val

src/Language/PureScript/Types.hs+4−12

@@ -40,10 +40,6 @@ data Type

40 --

41 = TUnknown Unknown

42 -- |

43− -- Javascript numbers

44− --

45− | Object Type

46− -- |

47 -- A named type variable

43 -- A named type variable

48 --

44 --

49 | TypeVar String

45 | TypeVar String

@@ -90,6 +86,10 @@ data Type

90 -- |

86 -- |

91 -- A placeholder used in pretty printing

87 -- A placeholder used in pretty printing

92 --

88 --

89+ | PrettyPrintObject Type

90+ -- |

91+ -- A placeholder used in pretty printing

92+ --

93 | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)

95-- |

@@ -120,12 +120,6 @@ isMonoType _ = True

120mkForAll :: [String] -> Type -> Type

121mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args

122

123−-- |

124−-- The empty record type

125−--

126−unit :: Type

127−unit = Object REmpty

128−

129-- |

123-- |

130-- Replace a type variable, taking into account variable shadowing

124-- Replace a type variable, taking into account variable shadowing

131--

125--

@@ -135,7 +129,6 @@ replaceTypeVars = replaceTypeVars' []

135 replaceTypeVars' bound name replacement = go bound

129 replaceTypeVars' bound name replacement = go bound

136 where

130 where

137 go :: [String] -> Type -> Type

131 go :: [String] -> Type -> Type

138− go bs (Object r) = Object $ go bs r

139 go _ (TypeVar v) | v == name = replacement

132 go _ (TypeVar v) | v == name = replacement

140 go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)

133 go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)

141 go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts

134 go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts

@@ -176,7 +169,6 @@ freeTypeVariables :: Type -> [String]

176freeTypeVariables = nub . go []

169freeTypeVariables = nub . go []

177 where

170 where

178 go :: [String] -> Type -> [String]

171 go :: [String] -> Type -> [String]

179− go bound (Object r) = go bound r

180 go bound (TypeVar v) | v `notElem` bound = [v]

172 go bound (TypeVar v) | v `notElem` bound = [v]

181 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

173 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

182 go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts

174 go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts