63d7784 · rowtype-yoga/purescript-native

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

on golang help sign in

New codegen approach for data constructors

63d7784Phil Freeman12 years ago

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

compare with golang

unifiedsplit

@@ -134,7 +134,7 @@ nameIsJsReserved name =

134-- Test if a string is a valid JS identifier (may return false negatives)

135--

136isIdent :: String -> Bool

137−isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True

137+isIdent s@(first : rest) | not (nameIsJsReserved s) && (isAlpha first || first == '_') && all isAlphaNum rest = True

138isIdent _ = False

139

140moduleNameToJs :: ModuleName -> String

src/Language/PureScript/CodeGen/JS.hs+32−18

@@ -81,14 +81,18 @@ importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleB

81 Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))

83imports :: Declaration -> [ModuleName]

84−imports =

84+imports (ImportDeclaration mn _ _) = [mn]

85+imports other =

85− let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])

86+ let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])

86− in f

87+ in f other

87 where

88 where

88− collect :: Value -> [ModuleName]

89+ collectV :: Value -> [ModuleName]

89− collect (Var (Qualified (Just mn) _)) = [mn]

90+ collectV (Var (Qualified (Just mn) _)) = [mn]

90− collect (Constructor (Qualified (Just mn) _)) = [mn]

91+ collectV (Constructor (Qualified (Just mn) _)) = [mn]

91− collect _ = []

92+ collectV _ = []

93+ collectB :: Binder -> [ModuleName]

94+ collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]

95+ collectB _ = []

93-- |

97-- |

94-- Generate code in the simplified Javascript intermediate representation for a declaration

98-- Generate code in the simplified Javascript intermediate representation for a declaration

@@ -102,16 +106,24 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do

102 js <- valueToJs opts mp e val

106 js <- valueToJs opts mp e val

103 return $ JSVariableIntroduction (identToJs ident) (Just js)

107 return $ JSVariableIntroduction (identToJs ident) (Just js)

104 return $ Just jss

108 return $ Just jss

105−declToJs _ mp (DataDeclaration _ _ ctors) _ = do

109+declToJs _ _ (DataDeclaration _ _ ctors) _ = do

106 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

110 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

111+ let _ctor = '_' : ctor

107− [JSVariableIntroduction ctor (Just (go pn 0 tys []))]

112+ in [ JSVariableIntroduction _ctor (Just (makeConstructor (length tys)))

113+ , JSVariableIntroduction ctor (Just (go pn 0 (length tys) []))

114+ ]

108 where

115 where

116+ makeConstructor :: Int -> JS

117+ makeConstructor n =

118+ let

119+ args = [ "value" ++ show index | index <- [0..n-1] ]

120+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]

121+ in JSFunction Nothing args (JSBlock body)

109− go :: ProperName -> Integer -> [Type] -> [JS] -> JS

122+ go :: ProperName -> Int -> Int -> [JS] -> JS

110− go pn _ [] values =

123+ go pn _ 0 values = JSApp (JSNew (JSVar ('_' : runProperName pn))) (reverse values)

111− JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

112− go pn index (_ : tys') values =

124+ go pn index n values =

113 JSFunction Nothing ["value" ++ show index]

125 JSFunction Nothing ["value" ++ show index]

114− (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

126+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])

115declToJs opts mp (DataBindingGroupDeclaration ds) e = do

127declToJs opts mp (DataBindingGroupDeclaration ds) e = do

116 jss <- mapM (\decl -> declToJs opts mp decl e) ds

128 jss <- mapM (\decl -> declToJs opts mp decl e) ds

117 return $ Just $ concat $ catMaybes jss

129 return $ Just $ concat $ catMaybes jss

@@ -123,7 +135,7 @@ declToJs _ _ _ _ = return Nothing

123-- Generate key//value pairs for an object literal exporting values from a module.

135-- Generate key//value pairs for an object literal exporting values from a module.

124--

136--

125exportToJs :: DeclarationRef -> [(String, JS)]

137exportToJs :: DeclarationRef -> [(String, JS)]

126−exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors

138+exportToJs (TypeRef _ (Just dctors)) = concatMap ((\n -> [('_' : n, var (Ident ('_' : n))), (n, var (Ident n))]) . runProperName) dctors

127exportToJs (ValueRef name) = [(runIdent name, var name)]

139exportToJs (ValueRef name) = [(runIdent name, var name)]

128exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]

140exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]

129exportToJs _ = []

141exportToJs _ = []

@@ -291,23 +303,25 @@ binderToJs _ _ varName done (BooleanBinder False) =

291 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

303 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

292binderToJs _ _ varName done (VarBinder ident) =

304binderToJs _ _ varName done (VarBinder ident) =

293 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

305 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

294−binderToJs m e varName done (ConstructorBinder ctor bs) = do

306+binderToJs m e varName done (ConstructorBinder ctor@(Qualified ctorModule (ProperName ctorName)) bs) = do

295 js <- go 0 done bs

307 js <- go 0 done bs

296 if isOnlyConstructor e ctor

308 if isOnlyConstructor e ctor

297 then

309 then

298 return js

310 return js

299 else

311 else

300− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))

312+ return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) _ctor))

301 (JSBlock js)

313 (JSBlock js)

302 Nothing]

314 Nothing]

303 where

315 where

316+ _ctor :: Qualified ProperName

317+ _ctor = Qualified ctorModule (ProperName ('_' : ctorName))

304 go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]

318 go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]

305 go _ done' [] = return done'

319 go _ done' [] = return done'

306 go index done' (binder:bs') = do

320 go index done' (binder:bs') = do

307 argVar <- freshName

321 argVar <- freshName

308 done'' <- go (index + 1) done' bs'

322 done'' <- go (index + 1) done' bs'

309 js <- binderToJs m e argVar done'' binder

323 js <- binderToJs m e argVar done'' binder

310− return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)

324+ return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)

311binderToJs m e varName done (ObjectBinder bs) = go done bs

325binderToJs m e varName done (ObjectBinder bs) = go done bs

312 where

326 where

313 go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

327 go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

src/Language/PureScript/CodeGen/JS/AST.hs+14

@@ -170,6 +170,10 @@ data JS

170 --

171 | JSApp JS [JS]

172 -- |

173+ -- Constructor

174+ --

175+ | JSNew JS

176+ -- |

173 -- Variable

177 -- Variable

174 --

178 --

175 | JSVar String

179 | JSVar String

@@ -218,6 +222,10 @@ data JS

218 --

222 --

219 | JSTypeOf JS

223 | JSTypeOf JS

220 -- |

224 -- |

225+ -- InstanceOf test

226+ --

227+ | JSInstanceOf JS JS

228+ -- |

221 -- Labelled statement

229 -- Labelled statement

222 --

230 --

223 | JSLabel String JS

231 | JSLabel String JS

@@ -262,6 +270,8 @@ everywhereOnJS f = go

262 go (JSThrow js) = f (JSThrow (go js))

270 go (JSThrow js) = f (JSThrow (go js))

263 go (JSTypeOf js) = f (JSTypeOf (go js))

271 go (JSTypeOf js) = f (JSTypeOf (go js))

264 go (JSLabel name js) = f (JSLabel name (go js))

272 go (JSLabel name js) = f (JSLabel name (go js))

273+ go (JSNew j) = f (JSNew (go j))

274+ go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))

265 go other = f other

275 go other = f other

266

276

267everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

277everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

@@ -288,6 +298,8 @@ everywhereOnJSTopDown f = go . f

288 go (JSThrow j) = JSThrow (go (f j))

298 go (JSThrow j) = JSThrow (go (f j))

289 go (JSTypeOf j) = JSTypeOf (go (f j))

299 go (JSTypeOf j) = JSTypeOf (go (f j))

290 go (JSLabel name j) = JSLabel name (go (f j))

300 go (JSLabel name j) = JSLabel name (go (f j))

301+ go (JSNew j) = JSNew (go (f j))

302+ go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))

291 go other = f other

303 go other = f other

292

304

293everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

305everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

@@ -314,4 +326,6 @@ everythingOnJS (<>) f = go

314 go j@(JSThrow j1) = f j <> go j1

326 go j@(JSThrow j1) = f j <> go j1

315 go j@(JSTypeOf j1) = f j <> go j1

327 go j@(JSTypeOf j1) = f j <> go j1

316 go j@(JSLabel _ j1) = f j <> go j1

328 go j@(JSLabel _ j1) = f j <> go j1

329+ go j@(JSNew j1) = f j <> go j1

330+ go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2

317 go other = f other

331 go other = f other

src/Language/PureScript/Pretty/JS.hs+14

@@ -174,6 +174,18 @@ typeOf = mkPattern match

174 match (JSTypeOf val) = Just ((), val)

175 match _ = Nothing

176

177+instanceOf :: Pattern PrinterState JS (JS, JS)

178+instanceOf = mkPattern match

179+ where

180+ match (JSInstanceOf val ty) = Just (val, ty)

181+ match _ = Nothing

182+

183+new :: Pattern PrinterState JS ((), JS)

184+new = mkPattern match

185+ where

186+ match (JSNew ctor) = Just ((), ctor)

187+ match _ = Nothing

188+

177unary :: UnaryOperator -> String -> Operator PrinterState JS String

189unary :: UnaryOperator -> String -> Operator PrinterState JS String

178unary op str = Wrap match (++)

190unary op str = Wrap match (++)

179 where

191 where

@@ -222,6 +234,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

222 operators =

234 operators =

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

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

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

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

237+ , [ Wrap new $ \_ s -> "new " ++ s ]

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

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

226 , [ Wrap lam $ \(name, args) ret -> "function "

239 , [ Wrap lam $ \(name, args) ret -> "function "

227 ++ fromMaybe "" name

240 ++ fromMaybe "" name

@@ -232,6 +245,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

232 , [ binary GreaterThan ">" ]

245 , [ binary GreaterThan ">" ]

233 , [ binary GreaterThanOrEqualTo ">=" ]

246 , [ binary GreaterThanOrEqualTo ">=" ]

234 , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

247 , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

248+ , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

235 , [ unary Not "!" ]

249 , [ unary Not "!" ]

236 , [ unary BitwiseNot "~" ]

250 , [ unary BitwiseNot "~" ]

237 , [ unary Negate "-" ]

251 , [ unary Negate "-" ]