e353c00 · rowtype-yoga/purescript-native

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

on golang help sign in

Object update syntax

e353c00Phil Freeman13 years ago

examples/passing/ObjectUpdate.psnew file+6

compare with golang

unifiedsplit

@@ -0,0 +1,6 @@

1+update = \o -> o { foo = "Foo" }

3+replace = \o -> case o of

4+ { foo = "Foo" } -> o { foo = "Bar" }

5+ { foo = "Bar" } -> o { bar = "Baz" }

6+ o -> o

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

@@ -49,6 +49,9 @@ literals = Pattern $ A.Kleisli match

49 match (BooleanLiteral False) = Just "false"

50 match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"

51 match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"

52+ match (ObjectUpdate o ps) = Just $ "Object.extend("

53+ ++ valueToJs o ++ ", { "

54+ ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"

52 match (Constructor name) = Just name

55 match (Constructor name) = Just name

53 match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

56 match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

54 match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"

57 match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"

@@ -197,7 +200,7 @@ binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' b

197 done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"

200 done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"

198

201

199objectPropertyToJs :: (String, Value) -> String

202objectPropertyToJs :: (String, Value) -> String

200−objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

203+objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value

201

204

202statementToJs :: Statement -> String

205statementToJs :: Statement -> String

203statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value

206statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value

src/PureScript/CodeGen/Pretty/Types.hs+5−6

@@ -47,18 +47,17 @@ typeLiterals = Pattern $ A.Kleisli match

47 match _ = Nothing

49prettyPrintRow :: Row -> String

50−prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList

50+prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []

51 where

52 nameAndTypeToPs :: String -> Type -> String

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

54 tailToPs :: Row -> String

55 tailToPs REmpty = ""

56− tailToPs (RUnknown u) = show u

56+ tailToPs (RUnknown u) = " | " ++ show u

57 tailToPs (RowVar var) = " | " ++ var

58− toList :: Row -> ([(String, Type)], Row)

58+ toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)

59− toList (RCons name ty row) = let (tys, rest) = toList row

59+ toList tys (RCons name ty row) = toList ((name, ty):tys) row

60− in ((name, ty):tys, rest)

61− toList r = ([], r)

60+ toList tys r = (tys, r)

63typeApp :: Pattern Type (Type, Type)

62typeApp :: Pattern Type (Type, Type)

64typeApp = Pattern $ A.Kleisli match

63typeApp = Pattern $ A.Kleisli match

src/PureScript/CodeGen/Pretty/Values.hs+7

@@ -65,6 +65,12 @@ indexer = Pattern $ A.Kleisli match

65 match (Indexer index val) = Just (prettyPrintValue index, val)

66 match _ = Nothing

68+objectUpdate :: Pattern Value ([String], Value)

69+objectUpdate = Pattern $ A.Kleisli match

70+ where

71+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

72+ match _ = Nothing

73+

68app :: Pattern Value (String, Value)

74app :: Pattern Value (String, Value)

69app = Pattern $ A.Kleisli match

75app = Pattern $ A.Kleisli match

70 where

76 where

@@ -104,6 +110,7 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue

104 operators =

110 operators =

105 OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

111 OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

106 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

112 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

113+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

107 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

114 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

108 , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]

115 , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]

109 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

116 , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

src/PureScript/Parser/Values.hs+9−1

@@ -109,6 +109,13 @@ parseValueAtom = C.indented *> P.choice (map P.try

109 , parseIfThenElse

110 , C.parens parseValue ])

111

112+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

113+parsePropertyUpdate = do

114+ name <- C.lexeme C.identifier

115+ C.lexeme $ C.indented *> P.char '='

116+ value <- C.indented *> parseValue

117+ return (name, value)

118+

112parseValue :: P.Parsec String ParseState Value

119parseValue :: P.Parsec String ParseState Value

113parseValue = do

120parseValue = do

114 customOps <- fixities <$> P.getState

121 customOps <- fixities <$> P.getState

@@ -118,7 +125,8 @@ parseValue = do

118 where

125 where

119 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

126 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

120 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)

127 postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)

121− , Indexer <$> (C.indented *> C.squares parseValue) ]

128+ , Indexer <$> (C.indented *> C.squares parseValue)

129+ , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]

122 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])

130 postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])

123 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

131 , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

124 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]

132 , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]

src/PureScript/TypeChecker/Types.hs+41−17

@@ -20,6 +20,8 @@ module PureScript.TypeChecker.Types (

20 typeOf

21) where

23+import Debug.Trace

24+

23import Data.List

25import Data.List

24import Data.Function

26import Data.Function

25import qualified Data.Data as D

27import qualified Data.Data as D

@@ -76,7 +78,7 @@ typeOf name val = do

76 solution <- solveTypeConstraints desugared emptyTypeSolution

78 solution <- solveTypeConstraints desugared emptyTypeSolution

77 let ty = fst (runTypeSolution solution) n

79 let ty = fst (runTypeSolution solution) n

78 allUnknownsBecameQuantified desugared solution ty

80 allUnknownsBecameQuantified desugared solution ty

79− return $ varIfUnknown $ desaturateAllTypeSynonyms ty

81+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty

81allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

83allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

82allUnknownsBecameQuantified cs solution ty = do

84allUnknownsBecameQuantified cs solution ty = do

@@ -95,6 +97,12 @@ allUnknownsBecameQuantified cs solution ty = do

95 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

97 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

96 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

98 guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

100+setify :: Row -> Row

101+setify = rowFromList . (M.toList . M.fromList *** id) . rowToList

102+

103+setifyAll :: (D.Data d) => d -> d

104+setifyAll = everywhere (mkT setify)

105+

98findUnknownTypes :: (D.Data d) => d -> [Int]

106findUnknownTypes :: (D.Data d) => d -> [Int]

99findUnknownTypes = everything (++) (mkQ [] f)

107findUnknownTypes = everything (++) (mkQ [] f)

100 where

108 where

@@ -216,6 +224,22 @@ occursCheck u = everything (||) $ flip extQ g $ mkQ False f

216 g (RUnknown u') | u' == u = True

224 g (RUnknown u') | u' == u = True

217 g _ = False

225 g _ = False

218

226

227+typesToRow :: [(String, Type)] -> Row

228+typesToRow [] = REmpty

229+typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)

230+

231+rowToList :: Row -> ([(String, Type)], Row)

232+rowToList (RCons name ty row) = let (tys, rest) = rowToList row

233+ in ((name, ty):tys, rest)

234+rowToList r = ([], r)

235+

236+rowFromList :: ([(String, Type)], Row) -> Row

237+rowFromList ([], r) = r

238+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

239+

240+ensureNoDuplicateProperties :: [(String, Value)] -> Check ()

241+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

242+

219typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

243typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

220typeConstraints _ v@(NumericLiteral _) = do

244typeConstraints _ v@(NumericLiteral _) = do

221 me <- fresh

245 me <- fresh

@@ -241,14 +265,20 @@ typeConstraints m b@(Binary op left right) = do

241 me <- fresh

265 me <- fresh

242 return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)

266 return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)

243typeConstraints m v@(ObjectLiteral ps) = do

267typeConstraints m v@(ObjectLiteral ps) = do

268+ ensureNoDuplicateProperties ps

244 all <- mapM (typeConstraints m . snd) ps

269 all <- mapM (typeConstraints m . snd) ps

245 let (cs, ns) = (concat . map fst &&& map snd) all

270 let (cs, ns) = (concat . map fst &&& map snd) all

246 me <- fresh

271 me <- fresh

247 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

272 let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

248 return ((TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v)) : cs, me)

273 return ((TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v)) : cs, me)

249− where

274+typeConstraints m v@(ObjectUpdate o ps) = do

250− typesToRow [] = REmpty

275+ ensureNoDuplicateProperties ps

251− typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)

276+ (cs1, n1) <- typeConstraints m o

277+ all <- mapM (typeConstraints m . snd) ps

278+ let (cs2, ns) = (concat . map fst &&& map snd) all

279+ row <- fresh

280+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

281+ return (TypeConstraint n1 (Object (rowFromList (tys, RUnknown row))) (ValueOrigin v) : cs1 ++ cs2, n1)

252typeConstraints m v@(Indexer index val) = do

282typeConstraints m v@(Indexer index val) = do

253 (cs1, n1) <- typeConstraints m index

283 (cs1, n1) <- typeConstraints m index

254 (cs2, n2) <- typeConstraints m val

284 (cs2, n2) <- typeConstraints m val

@@ -563,8 +593,8 @@ unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " wit

563unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

593unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

564unifyRows o r1 r2 =

594unifyRows o r1 r2 =

565 let

595 let

566− (s1, r1') = toList r1

596+ (s1, r1') = rowToList r1

567− (s2, r2') = toList r2

597+ (s2, r2') = rowToList r2

568 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

598 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

569 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

599 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

570 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

600 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

@@ -576,20 +606,14 @@ unifyRows o r1 r2 =

576 unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

606 unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

577 unifyRows' o [] (RUnknown u) sd r = do

607 unifyRows' o [] (RUnknown u) sd r = do

578 rowOccursCheck u r

608 rowOccursCheck u r

579− return [RowConstraint u (fromList (sd, r)) o]

609+ return [RowConstraint u (rowFromList (sd, r)) o]

580 unifyRows' o sd r [] (RUnknown u) = do

610 unifyRows' o sd r [] (RUnknown u) = do

581 rowOccursCheck u r

611 rowOccursCheck u r

582− return [RowConstraint u (fromList (sd, r)) o]

612+ return [RowConstraint u (rowFromList (sd, r)) o]

583− unifyRows' o ((name, ty):row) r others (RUnknown u) = do

613+ unifyRows' o ns@((name, ty):row) r others (RUnknown u) | not (occursCheck u (ty, row)) = do

584 u' <- fresh

614 u' <- fresh

585 cs <- unifyRows' o row r others (RUnknown u')

615 cs <- unifyRows' o row r others (RUnknown u')

586 return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)

616 return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)

587 unifyRows' _ [] REmpty [] REmpty = return []

617 unifyRows' _ [] REmpty [] REmpty = return []

618+ unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return []

588− unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."

619+ unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."

589− toList :: Row -> ([(String, Type)], Row)

590− toList (RCons name ty row) = let (tys, rest) = toList row

591− in ((name, ty):tys, rest)

592− toList r = ([], r)

593− fromList :: ([(String, Type)], Row) -> Row

594− fromList ([], r) = r

595− fromList ((name, t):ts, r) = RCons name t (fromList (ts, r))

src/PureScript/Values.hs+1

@@ -58,6 +58,7 @@ data Value

58 | Indexer Value Value

59 | ObjectLiteral [(String, Value)]

60 | Accessor String Value

61+ | ObjectUpdate Value [(String, Value)]

61 | Abs [Ident] Value

62 | Abs [Ident] Value

62 | App Value [Value]

63 | App Value [Value]

63 | Var Ident

64 | Var Ident