e353c00 · rowtype-yoga/purescript-native

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

Object update syntax

commite353c00cc255cb9b15588f3c06af76815834db1d authorPhil Freeman <paf31@cantab.net> dateWed 30 Oct 2013, 17:32 (13 years ago) parent2302594

7 files changed+73−25

compare with golang

unifiedsplit

examples/passing/ObjectUpdate.ps+6 src/PureScript/CodeGen/JS.hs+4−1 src/PureScript/CodeGen/Pretty/Types.hs+5−6 src/PureScript/CodeGen/Pretty/Values.hs+7 src/PureScript/Parser/Values.hs+9−1 src/PureScript/TypeChecker/Types.hs+41−17 src/PureScript/Values.hs+1

examples/passing/ObjectUpdate.psnew file+6

@@ -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

4949 match (BooleanLiteral False) = Just "false"

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

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

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

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

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

5255 match (Constructor name) = Just name

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

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

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

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

198201

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

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

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

201204

202205statementToJs :: Statement -> String

203206statementToJs (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

4747 match _ = Nothing

4848

4949prettyPrintRow :: 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 []

5151 where

5252 nameAndTypeToPs :: String -> Type -> String

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

5454 tailToPs :: Row -> String

5555 tailToPs REmpty = ""

56− tailToPs (RUnknown u) = show u

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

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

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

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

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

61− toList r = ([], r)

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

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

60+ toList tys r = (tys, r)

6261

6362typeApp :: Pattern Type (Type, Type)

6463typeApp = Pattern $ A.Kleisli match

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

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

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

6666 match _ = Nothing

6767

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+

6874app :: Pattern Value (String, Value)

6975app = Pattern $ A.Kleisli match

7076 where

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

104110 operators =

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

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

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

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

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

109116 , [ 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

109109 , parseIfThenElse

110110 , C.parens parseValue ])

111111

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+

112119parseValue :: P.Parsec String ParseState Value

113120parseValue = do

114121 customOps <- fixities <$> P.getState

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

118125 where

119126 indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

120127 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))) ]

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

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

124132 , 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 (

2020 typeOf

2121) where

2222

23+import Debug.Trace

24+

2325import Data.List

2426import Data.Function

2527import qualified Data.Data as D

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

7678 solution <- solveTypeConstraints desugared emptyTypeSolution

7779 let ty = fst (runTypeSolution solution) n

7880 allUnknownsBecameQuantified desugared solution ty

79− return $ varIfUnknown $ desaturateAllTypeSynonyms ty

81+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty

8082

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

8284allUnknownsBecameQuantified cs solution ty = do

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

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

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

9799

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+

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

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

100108 where

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

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

217225 g _ = False

218226

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+

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

220244typeConstraints _ v@(NumericLiteral _) = do

221245 me <- fresh

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

241265 me <- fresh

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

243267typeConstraints m v@(ObjectLiteral ps) = do

268+ ensureNoDuplicateProperties ps

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

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

246271 me <- fresh

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

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

249− where

250− typesToRow [] = REmpty

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

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

275+ ensureNoDuplicateProperties ps

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)

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

253283 (cs1, n1) <- typeConstraints m index

254284 (cs2, n2) <- typeConstraints m val

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

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

564594unifyRows o r1 r2 =

565595 let

566− (s1, r1') = toList r1

567− (s2, r2') = toList r2

596+ (s1, r1') = rowToList r1

597+ (s2, r2') = rowToList r2

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

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

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

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

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

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

578608 rowOccursCheck u r

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

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

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

581611 rowOccursCheck u r

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

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

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

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

584614 u' <- fresh

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

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

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

588− unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (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))

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

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

src/PureScript/Values.hs+1

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

5858 | Indexer Value Value

5959 | ObjectLiteral [(String, Value)]

6060 | Accessor String Value

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

6162 | Abs [Ident] Value

6263 | App Value [Value]

6364 | Var Ident