adc70ed · rowtype-yoga/purescript-native

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

Support arrays and objects in assignments

commitadc70ed6d399a5d38aa866c75df9db545ea3db48 authorPhil Freeman <paf31@cantab.net> dateFri 4 Oct 2013, 18:01 (13 years ago) parented3fc70

6 files changed+103−54

compare with golang

unifiedsplit

README.md−1 examples/Assign.ps+7 src/PureScript/CodeGen.hs+29−20 src/PureScript/Parser/Values.hs+29−19 src/PureScript/TypeChecker/Types.hs+30−12 src/PureScript/Values.hs+8−2

README.md−1

@@ -14,7 +14,6 @@ A small strongly, statically typed compile-to-JS language with basic extensible

1414## TODO

1515

1616- IfThenElse expressions

17−- Accessors and indices in assignments

1817- Type Synonyms

1918- User defined operators

2019- Mutually recursive functions

examples/Assign.psnew file+7

@@ -0,0 +1,7 @@

1+test = \ -> {

2+ var x = [];

3+ for (var i = 0; i < 10; i = i + 1) {

4+ x[i] = i;

5+ }

6+ return x;

7+}

src/PureScript/CodeGen.hs+29−20

@@ -181,25 +181,29 @@ valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

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

182182 , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"

183183 , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"

184− , unary Not "!"

185− , unary BitwiseNot "~"

186− , unary Negate "-"

187− , binary Multiply "*"

188− , binary Divide "/"

189− , binary Modulus "%"

190− , binary Concat "++"

191− , binary Add "+"

192− , binary Subtract "-"

193− , binary ShiftLeft "<<"

194− , binary ShiftRight ">>"

195− , binary ZeroFillShiftRight ">>>"

196− , binary EqualTo "==="

197− , binary NotEqualTo "!=="

198− , binary BitwiseAnd "&"

199− , binary BitwiseXor "^"

200− , binary BitwiseOr "|"

201− , binary And "&&"

202− , binary Or "||"

184+ , binary LessThan "<"

185+ , binary LessThanOrEqualTo "<="

186+ , binary GreaterThan ">"

187+ , binary GreaterThanOrEqualTo ">="

188+ , unary Not "!"

189+ , unary BitwiseNot "~"

190+ , unary Negate "-"

191+ , binary Multiply "*"

192+ , binary Divide "/"

193+ , binary Modulus "%"

194+ , binary Concat "++"

195+ , binary Add "+"

196+ , binary Subtract "-"

197+ , binary ShiftLeft "<<"

198+ , binary ShiftRight ">>"

199+ , binary ZeroFillShiftRight ">>>"

200+ , binary EqualTo "==="

201+ , binary NotEqualTo "!=="

202+ , binary BitwiseAnd "&"

203+ , binary BitwiseXor "^"

204+ , binary BitwiseOr "|"

205+ , binary And "&&"

206+ , binary Or "||"

203207 ]

204208

205209unaryOperatorString :: UnaryOperator -> String

@@ -275,7 +279,7 @@ objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

275279

276280statementToJs :: Statement -> String

277281statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value

278−statementToJs (Assignment target value) = target ++ " = " ++ valueToJs value

282+statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value

279283statementToJs (While cond sts) = "while ("

280284 ++ valueToJs cond ++ ") {"

281285 ++ intercalate ";" (map statementToJs sts) ++ "}"

@@ -290,3 +294,8 @@ statementToJs (IfThenElse cond thens elses) = "if ("

290294 ++ flip (maybe "") elses (\sts ->

291295 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")

292296statementToJs (Return value) = "return " ++ valueToJs value

297+

298+assignmentTargetToJs :: AssignmentTarget -> String

299+assignmentTargetToJs (AssignVariable var) = var

300+assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"

301+assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop

src/PureScript/Parser/Values.hs+29−19

@@ -22,6 +22,7 @@ import qualified PureScript.Parser.Common as C

2222import Control.Applicative

2323import qualified Text.Parsec as P

2424import Text.Parsec.Expr

25+import Control.Monad

2526import Control.Arrow (Arrow(..))

2627import PureScript.Parser.Types

2728import PureScript.Types

@@ -74,7 +75,7 @@ parseCaseAlternative :: P.Parsec String () (Binder, Value)

7475parseCaseAlternative = (,) <$> (parseBinder <* C.lexeme (P.string "->")) <*> parseValue

7576

7677parseBlock :: P.Parsec String () Value

77−parseBlock = Block <$> (C.braces $ P.many parseStatement)

78+parseBlock = Block <$> (C.braces $ P.many (parseStatement True))

7879

7980parseValueAtom :: P.Parsec String () Value

8081parseValueAtom = P.choice $ map P.try

@@ -100,7 +101,10 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

100101 , [ Prefix $ C.lexeme (P.char '!') >> return (Unary Not)

101102 , Prefix $ C.lexeme (P.char '~') >> return (Unary BitwiseNot)

102103 , Prefix $ C.lexeme (P.char '-') >> return (Unary Negate) ]

103− , [ Infix (C.lexeme (P.char '*') >> return (Binary Multiply)) AssocRight

104+ , [ Infix (C.lexeme (P.try (P.string "<=")) >> return (Binary LessThanOrEqualTo)) AssocRight

105+ , Infix (C.lexeme (P.try (P.string ">=")) >> return (Binary GreaterThanOrEqualTo)) AssocRight

106+ , Infix (C.lexeme (P.try (P.char '<' <* P.notFollowedBy (P.char '<'))) >> return (Binary LessThan)) AssocRight ]

107+ , [ Infix (C.lexeme (P.try (P.char '>' <* P.notFollowedBy (P.char '>'))) >> return (Binary GreaterThan)) AssocRight

104108 , Infix (C.lexeme (P.char '/') >> return (Binary Divide)) AssocRight

105109 , Infix (C.lexeme (P.char '%') >> return (Binary Modulus)) AssocRight ]

106110 , [ Infix (C.lexeme (P.try (P.string "++")) >> return (Binary Concat)) AssocRight

@@ -118,25 +122,25 @@ parseValue = buildExpressionParser operators $ C.fold (C.lexeme typedValue) (C.l

118122 , [ Infix (C.lexeme (P.string "||") >> return (Binary Or)) AssocRight ]

119123 ]

120124

121−parseVariableIntroduction :: P.Parsec String () Statement

122−parseVariableIntroduction = do

125+parseVariableIntroduction :: Bool -> P.Parsec String () Statement

126+parseVariableIntroduction requireSemi = do

123127 C.reserved "var"

124128 name <- C.identifier

125129 C.lexeme $ P.char '='

126130 value <- parseValue

127− C.semi

131+ when requireSemi (void C.semi)

128132 return $ VariableIntroduction name value

129133

130−parseAssignment :: P.Parsec String () (Statement)

131−parseAssignment = do

132− tgt <- C.identifier

134+parseAssignment :: Bool -> P.Parsec String () (Statement)

135+parseAssignment requireSemi = do

136+ tgt <- parseAssignmentTarget

133137 C.lexeme $ P.char '='

134138 value <- parseValue

135− C.semi

139+ when requireSemi (void C.semi)

136140 return $ Assignment tgt value

137141

138142parseManyStatements :: P.Parsec String () [Statement]

139−parseManyStatements = C.braces $ P.many parseStatement

143+parseManyStatements = C.braces $ P.many (parseStatement True)

140144

141145parseWhile :: P.Parsec String () Statement

142146parseWhile = While <$> (C.reserved "while" *> C.parens parseValue)

@@ -146,9 +150,9 @@ parseFor :: P.Parsec String () Statement

146150parseFor = For <$> (C.reserved "for" *> C.parens forIntro)

147151 <*> parseManyStatements

148152 where

149− forIntro = (,,) <$> parseStatement

153+ forIntro = (,,) <$> parseStatement False

150154 <*> (C.semi *> parseValue)

151− <*> (C.semi *> parseStatement)

155+ <*> (C.semi *> parseStatement False)

152156

153157parseIfThenElse :: P.Parsec String () Statement

154158parseIfThenElse = IfThenElse

@@ -156,17 +160,17 @@ parseIfThenElse = IfThenElse

156160 <*> parseManyStatements

157161 <*> P.optionMaybe (C.reserved "else" *> parseManyStatements)

158162

159−parseReturn :: P.Parsec String () Statement

160−parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.semi)

163+parseReturn :: Bool -> P.Parsec String () Statement

164+parseReturn requireSemi = Return <$> (C.reserved "return" *> parseValue <* when requireSemi (void C.semi))

161165

162−parseStatement :: P.Parsec String () Statement

163−parseStatement = P.choice $ map P.try

164− [ parseVariableIntroduction

165− , parseAssignment

166+parseStatement :: Bool -> P.Parsec String () Statement

167+parseStatement requireSemi = P.choice $ map P.try

168+ [ parseVariableIntroduction requireSemi

169+ , parseAssignment requireSemi

166170 , parseWhile

167171 , parseFor

168172 , parseIfThenElse

169− , parseReturn ]

173+ , parseReturn requireSemi ]

170174

171175parseStringBinder :: P.Parsec String () Binder

172176parseStringBinder = StringBinder <$> C.stringLiteral

@@ -210,3 +214,9 @@ parseBinder = P.choice $ map P.try

210214 , parseObjectBinder

211215 , parseArrayBinder

212216 , C.parens parseBinder ]

217+

218+parseAssignmentTarget :: P.Parsec String () AssignmentTarget

219+parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.identifier)

220+ where

221+ operators = [ [ Postfix $ AssignArrayIndex <$> C.squares parseValue

222+ , Postfix $ AssignObjectProperty <$> (C.dot *> C.identifier) ] ]

src/PureScript/TypeChecker/Types.hs+30−12

@@ -210,10 +210,10 @@ binaryOperatorConstraints Subtract = symBinOpConstraints Number

210210binaryOperatorConstraints Multiply = symBinOpConstraints Number

211211binaryOperatorConstraints Divide = symBinOpConstraints Number

212212binaryOperatorConstraints Modulus = symBinOpConstraints Number

213−binaryOperatorConstraints LessThan = symBinOpConstraints Number

214−binaryOperatorConstraints LessThanOrEqualTo = symBinOpConstraints Number

215−binaryOperatorConstraints GreaterThan = symBinOpConstraints Number

216−binaryOperatorConstraints GreaterThanOrEqualTo = symBinOpConstraints Number

213+binaryOperatorConstraints LessThan = asymBinOpConstraints Number Boolean

214+binaryOperatorConstraints LessThanOrEqualTo = asymBinOpConstraints Number Boolean

215+binaryOperatorConstraints GreaterThan = asymBinOpConstraints Number Boolean

216+binaryOperatorConstraints GreaterThanOrEqualTo = asymBinOpConstraints Number Boolean

217217binaryOperatorConstraints BitwiseAnd = symBinOpConstraints Number

218218binaryOperatorConstraints BitwiseOr = symBinOpConstraints Number

219219binaryOperatorConstraints BitwiseXor = symBinOpConstraints Number

@@ -230,7 +230,10 @@ equalityBinOpConstraints :: Int -> Int -> Int -> [TypeConstraint]

230230equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown right), TypeConstraint result Boolean]

231231

232232symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]

233−symBinOpConstraints ty left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result ty]

233+symBinOpConstraints ty left right result = asymBinOpConstraints ty ty left right result

234+

235+asymBinOpConstraints :: Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

236+asymBinOpConstraints ty res left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result res]

234237

235238typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map String Int)

236239typeConstraintsForBinder val (StringBinder _) = constantBinder val String

@@ -298,12 +301,10 @@ typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do

298301 (cs1, n1) <- typeConstraints m val

299302 return $ (cs1, False, M.insert name n1 mass)

300303 Just ty -> throwError $ "Variable with name " ++ name ++ " already exists."

301−typeConstraintsForStatement m mass ret (Assignment name val) = do

302− case M.lookup name (m `M.union` mass) of

303− Nothing -> throwError $ "No local variable with name " ++ name

304− Just ty -> do

305− (cs1, n1) <- typeConstraints m val

306− return ((TypeConstraint n1 (TUnknown ty)) : cs1, False, mass)

304+typeConstraintsForStatement m mass ret (Assignment tgt val) = do

305+ (cs1, n1) <- typeConstraints m val

306+ cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

307+ return (cs1 ++ cs2, False, mass)

307308typeConstraintsForStatement m mass ret (While val inner) = do

308309 (cs1, n1) <- typeConstraints m val

309310 (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner

@@ -326,9 +327,26 @@ typeConstraintsForStatement m mass ret (For (init, cond, cont) inner) = do

326327 (cs4, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass2) mass2 ret inner

327328 return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3 ++ cs4, allCodePathsReturn, mass)

328329typeConstraintsForStatement m mass ret (Return val) = do

329− (cs1, n1) <- typeConstraints m val

330+ (cs1, n1) <- typeConstraints (m `M.union` mass) val

330331 return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)

331332

333+typeConstraintsForAssignmentTarget :: M.Map String Int -> M.Map String Int -> Int -> AssignmentTarget -> Check [TypeConstraint]

334+typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =

335+ case M.lookup var mass of

336+ Nothing -> throwError $ "No local variable with name " ++ var

337+ Just ty -> do

338+ return [TypeConstraint nval (TUnknown ty)]

339+typeConstraintsForAssignmentTarget m mass nval (AssignArrayIndex index tgt) = do

340+ arr <- fresh

341+ (cs1, n1) <- typeConstraints (m `M.union` mass) index

342+ cs2 <- typeConstraintsForAssignmentTarget m mass arr tgt

343+ return $ (TypeConstraint arr (Array (TUnknown nval))) : (TypeConstraint n1 Number) : cs1 ++ cs2

344+typeConstraintsForAssignmentTarget m mass nval (AssignObjectProperty prop tgt) = do

345+ obj <- fresh

346+ row <- fresh

347+ cs <- typeConstraintsForAssignmentTarget m mass obj tgt

348+ return $ (TypeConstraint obj (Object (RCons prop (TUnknown nval) $ RUnknown row))) : cs

349+

332350typeConstraintsForBlock :: M.Map String Int -> M.Map String Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map String Int)

333351typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

334352typeConstraintsForBlock m mass ret (s:ss) = do

src/PureScript/Values.hs+8−2

@@ -17,7 +17,8 @@ module PureScript.Values (

1717 BinaryOperator (..),

1818 Value (..),

1919 Statement (..),

20− Binder (..)

20+ Binder (..),

21+ AssignmentTarget (..)

2122) where

2223

2324import PureScript.Types

@@ -69,7 +70,7 @@ data Value

6970

7071data Statement

7172 = VariableIntroduction String Value

72− | Assignment String Value

73+ | Assignment AssignmentTarget Value

7374 | While Value [Statement]

7475 | For (Statement, Value, Statement) [Statement]

7576 | IfThenElse (Value) [Statement] (Maybe [Statement])

@@ -84,3 +85,8 @@ data Binder

8485 | UnaryBinder String Binder

8586 | ObjectBinder [(String, Binder)]

8687 | ArrayBinder [Binder] (Maybe Binder) deriving Show

88+

89+data AssignmentTarget

90+ = AssignVariable String

91+ | AssignObjectProperty String AssignmentTarget

92+ | AssignArrayIndex Value AssignmentTarget deriving Show