adc70ed · rowtype-yoga/purescript-native

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

on golang help sign in

Support arrays and objects in assignments

adc70edPhil Freeman13 years ago

README.md−1

compare with golang

unifiedsplit

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

14## TODO

16- IfThenElse expressions

17−- Accessors and indices in assignments

18- Type Synonyms

17- Type Synonyms

19- User defined operators

18- User defined operators

20- Mutually recursive functions

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

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

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

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

184+ , binary LessThan "<"

185+ , binary LessThanOrEqualTo "<="

186+ , binary GreaterThan ">"

187+ , binary GreaterThanOrEqualTo ">="

184− , unary Not "!"

188+ , unary Not "!"

185− , unary BitwiseNot "~"

189+ , unary BitwiseNot "~"

186− , unary Negate "-"

190+ , unary Negate "-"

187− , binary Multiply "*"

191+ , binary Multiply "*"

188− , binary Divide "/"

192+ , binary Divide "/"

189− , binary Modulus "%"

193+ , binary Modulus "%"

190− , binary Concat "++"

194+ , binary Concat "++"

191− , binary Add "+"

195+ , binary Add "+"

192− , binary Subtract "-"

196+ , binary Subtract "-"

193− , binary ShiftLeft "<<"

197+ , binary ShiftLeft "<<"

194− , binary ShiftRight ">>"

198+ , binary ShiftRight ">>"

195− , binary ZeroFillShiftRight ">>>"

199+ , binary ZeroFillShiftRight ">>>"

196− , binary EqualTo "==="

200+ , binary EqualTo "==="

197− , binary NotEqualTo "!=="

201+ , binary NotEqualTo "!=="

198− , binary BitwiseAnd "&"

202+ , binary BitwiseAnd "&"

199− , binary BitwiseXor "^"

203+ , binary BitwiseXor "^"

200− , binary BitwiseOr "|"

204+ , binary BitwiseOr "|"

201− , binary And "&&"

205+ , binary And "&&"

202− , binary Or "||"

206+ , binary Or "||"

203 ]

207 ]

204

208

205unaryOperatorString :: UnaryOperator -> String

209unaryOperatorString :: UnaryOperator -> String

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

275

279

276statementToJs :: Statement -> String

280statementToJs :: Statement -> String

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

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

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

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

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

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

280 ++ valueToJs cond ++ ") {"

284 ++ valueToJs cond ++ ") {"

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

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

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

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

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

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

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

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

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

22import Control.Applicative

23import qualified Text.Parsec as P

24import Text.Parsec.Expr

25+import Control.Monad

25import Control.Arrow (Arrow(..))

26import Control.Arrow (Arrow(..))

26import PureScript.Parser.Types

27import PureScript.Parser.Types

27import PureScript.Types

28import PureScript.Types

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

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

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

76parseBlock :: P.Parsec String () Value

77parseBlock :: P.Parsec String () Value

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

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

79parseValueAtom :: P.Parsec String () Value

80parseValueAtom :: P.Parsec String () Value

80parseValueAtom = P.choice $ map P.try

81parseValueAtom = P.choice $ map P.try

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

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

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

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

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

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

103 , 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

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

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

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

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

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

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

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

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

119 ]

123 ]

120

124

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

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

122−parseVariableIntroduction = do

126+parseVariableIntroduction requireSemi = do

123 C.reserved "var"

127 C.reserved "var"

124 name <- C.identifier

128 name <- C.identifier

125 C.lexeme $ P.char '='

129 C.lexeme $ P.char '='

126 value <- parseValue

130 value <- parseValue

127− C.semi

131+ when requireSemi (void C.semi)

128 return $ VariableIntroduction name value

132 return $ VariableIntroduction name value

129

133

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

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

131−parseAssignment = do

135+parseAssignment requireSemi = do

132− tgt <- C.identifier

136+ tgt <- parseAssignmentTarget

133 C.lexeme $ P.char '='

137 C.lexeme $ P.char '='

134 value <- parseValue

138 value <- parseValue

135− C.semi

139+ when requireSemi (void C.semi)

136 return $ Assignment tgt value

140 return $ Assignment tgt value

137

141

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

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

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

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

140

144

141parseWhile :: P.Parsec String () Statement

145parseWhile :: P.Parsec String () Statement

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

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

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

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

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

147 <*> parseManyStatements

151 <*> parseManyStatements

148 where

152 where

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

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

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

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

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

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

152

156

153parseIfThenElse :: P.Parsec String () Statement

157parseIfThenElse :: P.Parsec String () Statement

154parseIfThenElse = IfThenElse

158parseIfThenElse = IfThenElse

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

156 <*> parseManyStatements

160 <*> parseManyStatements

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

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

158

162

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

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

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

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

161

165

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

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

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

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

164− [ parseVariableIntroduction

168+ [ parseVariableIntroduction requireSemi

165− , parseAssignment

169+ , parseAssignment requireSemi

166 , parseWhile

170 , parseWhile

167 , parseFor

171 , parseFor

168 , parseIfThenElse

172 , parseIfThenElse

169− , parseReturn ]

173+ , parseReturn requireSemi ]

170

174

171parseStringBinder :: P.Parsec String () Binder

175parseStringBinder :: P.Parsec String () Binder

172parseStringBinder = StringBinder <$> C.stringLiteral

176parseStringBinder = StringBinder <$> C.stringLiteral

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

210 , parseObjectBinder

214 , parseObjectBinder

211 , parseArrayBinder

215 , parseArrayBinder

212 , C.parens parseBinder ]

216 , 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

210binaryOperatorConstraints Multiply = symBinOpConstraints Number

211binaryOperatorConstraints Divide = symBinOpConstraints Number

212binaryOperatorConstraints Modulus = symBinOpConstraints Number

213−binaryOperatorConstraints LessThan = symBinOpConstraints Number

213+binaryOperatorConstraints LessThan = asymBinOpConstraints Number Boolean

214−binaryOperatorConstraints LessThanOrEqualTo = symBinOpConstraints Number

214+binaryOperatorConstraints LessThanOrEqualTo = asymBinOpConstraints Number Boolean

215−binaryOperatorConstraints GreaterThan = symBinOpConstraints Number

215+binaryOperatorConstraints GreaterThan = asymBinOpConstraints Number Boolean

216−binaryOperatorConstraints GreaterThanOrEqualTo = symBinOpConstraints Number

216+binaryOperatorConstraints GreaterThanOrEqualTo = asymBinOpConstraints Number Boolean

217binaryOperatorConstraints BitwiseAnd = symBinOpConstraints Number

218binaryOperatorConstraints BitwiseOr = symBinOpConstraints Number

219binaryOperatorConstraints BitwiseXor = symBinOpConstraints Number

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

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

231

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

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

234+

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

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

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

234

237

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

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

236typeConstraintsForBinder val (StringBinder _) = constantBinder val String

239typeConstraintsForBinder val (StringBinder _) = constantBinder val String

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

298 (cs1, n1) <- typeConstraints m val

301 (cs1, n1) <- typeConstraints m val

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

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

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

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

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

304+typeConstraintsForStatement m mass ret (Assignment tgt 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

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

306+ cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

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

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

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

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

308 (cs1, n1) <- typeConstraints m val

309 (cs1, n1) <- typeConstraints m val

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

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

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

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

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

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

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

328typeConstraintsForStatement m mass ret (Return val) = do

329typeConstraintsForStatement m mass ret (Return val) = do

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

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

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

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

331

332

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+

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

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

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

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

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

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

src/PureScript/Values.hs+8−2

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

17 BinaryOperator (..),

18 Value (..),

19 Statement (..),

20− Binder (..)

20+ Binder (..),

21+ AssignmentTarget (..)

21) where

22) where

23import PureScript.Types

24import PureScript.Types

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

70data Statement

71data Statement

71 = VariableIntroduction String Value

72 = VariableIntroduction String Value

72− | Assignment String Value

73+ | Assignment AssignmentTarget Value

73 | While Value [Statement]

74 | While Value [Statement]

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

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

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

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

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

84 | UnaryBinder String Binder

85 | UnaryBinder String Binder

85 | ObjectBinder [(String, Binder)]

86 | ObjectBinder [(String, Binder)]

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

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

88+

89+data AssignmentTarget

90+ = AssignVariable String

91+ | AssignObjectProperty String AssignmentTarget

92+ | AssignArrayIndex Value AssignmentTarget deriving Show