e6ac3d3 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Update JS gen to use canonicals & be nicer/faster

e6ac3d3Evan Czaplicki12 years ago

Elm.cabal+2

compare with master

unifiedsplit

@@ -53,6 +53,7 @@ Library

53 Generate.JavaScript,

54 Generate.JavaScript.Helpers,

55 Generate.JavaScript.Ports,

56+ Generate.JavaScript.Variable,

56 Generate.Markdown,

57 Generate.Markdown,

57 Generate.Html,

58 Generate.Html,

58 Generate.Cases,

59 Generate.Cases,

@@ -144,6 +145,7 @@ Executable elm

144 Generate.JavaScript,

145 Generate.JavaScript,

145 Generate.JavaScript.Helpers,

146 Generate.JavaScript.Helpers,

146 Generate.JavaScript.Ports,

147 Generate.JavaScript.Ports,

148+ Generate.JavaScript.Variable,

147 Generate.Markdown,

149 Generate.Markdown,

148 Generate.Html,

150 Generate.Html,

149 Generate.Cases,

151 Generate.Cases,

compiler/Generate/JavaScript.hs+82−81

@@ -10,9 +10,10 @@ import qualified Data.Set as Set

10import Language.ECMAScript3.PrettyPrint

11import Language.ECMAScript3.Syntax

13−import Generate.JavaScript.Helpers

13+import Generate.JavaScript.Helpers as Help

14import qualified Generate.Cases as Case

15import qualified Generate.JavaScript.Ports as Port

16+import qualified Generate.JavaScript.Variable as Var

16import qualified Generate.Markdown as MD

17import qualified Generate.Markdown as MD

18import AST.Annotation

19import AST.Annotation

@@ -23,62 +24,52 @@ import qualified AST.Module as Module

23import qualified AST.Helpers as Help

24import qualified AST.Helpers as Help

24import AST.Literal

25import AST.Literal

25import qualified AST.Pattern as P

26import qualified AST.Pattern as P

26−import AST.PrettyPrint (renderPretty)

27import qualified AST.Variable as Var

29varDecl :: String -> Expression () -> VarDecl ()

30varDecl x expr =

31 VarDecl () (var x) (Just expr)

33−include :: String -> String -> VarDecl ()

33+internalImports :: String -> [VarDecl ()]

34−include alias moduleName =

35− varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

36−

37−internalImports :: String -> Statement ()

38internalImports name =

34internalImports name =

39− VarDeclStmt ()

40− [ varDecl "_N" (obj "Elm.Native")

35+ [ varDecl "_N" (obj ["Elm","Native"])

41− , include "_U" "_N.Utils"

36+ , include "_U" "Utils"

42− , include "_L" "_N.List"

37+ , include "_L" "List"

43− , include "_A" "_N.Array"

38+ , include "_A" "Array"

44− , include "_E" "_N.Error"

39+ , include "_E" "Error"

45− , varDecl "$moduleName" (string name)

40+ , varDecl Help.localModuleName (string name)

46 ]

41 ]

42+ where

43+ include :: String -> String -> VarDecl ()

44+ include alias modul =

45+ varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")

46+

47+_Utils :: String -> Expression ()

48+_Utils x = obj ["_U", x]

49+

50+_List :: String -> Expression ()

51+_List x = obj ["_L", x]

48literal :: Literal -> Expression ()

53literal :: Literal -> Expression ()

49literal lit =

54literal lit =

50 case lit of

55 case lit of

51− Chr c -> obj "_U.chr" <| string [c]

56+ Chr c -> _Utils "chr" <| string [c]

52 Str s -> string s

57 Str s -> string s

53 IntNum n -> IntLit () n

58 IntNum n -> IntLit () n

54 FloatNum n -> NumLit () n

59 FloatNum n -> NumLit () n

55 Boolean b -> BoolLit () b

60 Boolean b -> BoolLit () b

57−canonical :: Var.Canonical -> Expression ()

58−canonical (Var.Canonical home name) =

59− case Help.isOp name of

60− True -> BracketRef () (dotSep (home' ++ ["_op"])) (string name)

61− False -> dotSep (home' ++ [map (swap '\'' '$') name])

62− where

63− swap from to c = if c == from then to else c

64−

65− home' =

66− case home of

67− Var.Local -> []

68− Var.BuiltIn -> []

69− Var.Module path -> [ map (swap '.' '$') path ]

70−

71expression :: Canonical.Expr -> State Int (Expression ())

62expression :: Canonical.Expr -> State Int (Expression ())

72expression (A region expr) =

63expression (A region expr) =

73 case expr of

64 case expr of

74− Var var -> return $ canonical var

65+ Var var -> return $ Var.canonical var

76 Literal lit -> return $ literal lit

67 Literal lit -> return $ literal lit

78 Range lo hi ->

69 Range lo hi ->

79 do lo' <- expression lo

70 do lo' <- expression lo

80 hi' <- expression hi

71 hi' <- expression hi

81− return $ obj "_L.range" `call` [lo',hi']

72+ return $ _List "range" `call` [lo',hi']

83 Access e x ->

74 Access e x ->

84 do e' <- expression e

75 do e' <- expression e

@@ -86,19 +77,19 @@ expression (A region expr) =

87 Remove e x ->

78 Remove e x ->

88 do e' <- expression e

79 do e' <- expression e

89− return $ obj "_U.remove" `call` [string x, e']

80+ return $ _Utils "remove" `call` [string x, e']

91 Insert e x v ->

82 Insert e x v ->

92 do v' <- expression v

83 do v' <- expression v

93 e' <- expression e

84 e' <- expression e

94− return $ obj "_U.insert" `call` [string x, v', e']

85+ return $ _Utils "insert" `call` [string x, v', e']

96 Modify e fs ->

87 Modify e fs ->

97 do e' <- expression e

88 do e' <- expression e

98 fs' <- forM fs $ \(f,v) -> do

89 fs' <- forM fs $ \(f,v) -> do

99 v' <- expression v

90 v' <- expression v

100 return $ ArrayLit () [string f, v']

91 return $ ArrayLit () [string f, v']

101− return $ obj "_U.replace" `call` [ArrayLit () fs', e']

92+ return $ _Utils "replace" `call` [ArrayLit () fs', e']

102

103 Record fields ->

94 Record fields ->

104 do fields' <- forM fields $ \(f,e) -> do

95 do fields' <- forM fields $ \(f,e) -> do

@@ -122,7 +113,7 @@ expression (A region expr) =

122 where

113 where

123 depattern (args, body) pattern =

114 depattern (args, body) pattern =

124 case pattern of

115 case pattern of

125− P.Var x -> return (args ++ [x], body)

116+ P.Var x -> return (args ++ [ Var.varName x ], body)

126 _ -> do arg <- Case.newVar

117 _ -> do arg <- Case.newVar

127 return ( args ++ [arg]

118 return ( args ++ [arg]

128 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

119 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

@@ -161,7 +152,7 @@ expression (A region expr) =

161 (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

152 (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

162 safeIfs branches'

153 safeIfs branches'

163 (A _ (Literal (Boolean True)), _) -> safeIfs branches'

154 (A _ (Literal (Boolean True)), _) -> safeIfs branches'

164− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

155+ _ -> ifs branches' (throw "If" region)

165 where

156 where

166 safeIfs branches = ifs (init branches) (snd (last branches))

157 safeIfs branches = ifs (init branches) (snd (last branches))

167 ifs branches finally = foldr iff finally branches

158 ifs branches finally = foldr iff finally branches

@@ -181,7 +172,7 @@ expression (A region expr) =

181

172

182 ExplicitList es ->

173 ExplicitList es ->

183 do es' <- mapM expression es

174 do es' <- mapM expression es

184− return $ obj "_L.fromArray" <| ArrayLit () es'

175+ return $ _List "fromArray" <| ArrayLit () es'

185

176

186 Data name es ->

177 Data name es ->

187 do es' <- mapM expression es

178 do es' <- mapM expression es

@@ -192,7 +183,7 @@ expression (A region expr) =

192

183

193 Markdown uid doc es ->

184 Markdown uid doc es ->

194 do es' <- mapM expression es

185 do es' <- mapM expression es

195− return $ obj "Text.markdown" `call` (string md : string uid : es')

186+ return $ obj ["Text","markdown"] `call` (string md : string uid : es')

196 where

187 where

197 pad = "<div style=\"height:0;width:0;\"> </div>"

188 pad = "<div style=\"height:0;width:0;\"> </div>"

198 md = pad ++ MD.toHtml doc ++ pad

189 md = pad ++ MD.toHtml doc ++ pad

@@ -201,11 +192,11 @@ expression (A region expr) =

201 return $ ObjectLit () [(PropString () "src", literal (Str src))]

192 return $ ObjectLit () [(PropString () "src", literal (Str src))]

202

193

203 PortIn name tipe ->

194 PortIn name tipe ->

204− return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]

195+ return $ obj ["Native","Ports","portIn"] `call` [ string name, Port.incoming tipe ]

205

196

206 PortOut name tipe value ->

197 PortOut name tipe value ->

207 do value' <- expression value

198 do value' <- expression value

208− return $ obj "Native.Ports.portOut" `call`

199+ return $ obj ["Native","Ports","portOut"] `call`

209 [ string name, Port.outgoing tipe, value' ]

200 [ string name, Port.outgoing tipe, value' ]

210

201

211definition :: Canonical.Def -> State Int [Statement ()]

202definition :: Canonical.Def -> State Int [Statement ()]

@@ -218,10 +209,10 @@ definition (Canonical.Definition pattern expr@(A region _) _) = do

218 let op = LBracket () (ref "_op") (string x) in

209 let op = LBracket () (ref "_op") (string x) in

219 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

210 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

220 | otherwise ->

211 | otherwise ->

221− return [ VarDeclStmt () [ assign x ] ]

212+ return [ VarDeclStmt () [ assign (Var.varName x) ] ]

222

213

223 P.Record fields ->

214 P.Record fields ->

224− let setField f = varDecl f (dotSep ["$",f]) in

215+ let setField f = varDecl f (obj ["$",f]) in

225 return [ VarDeclStmt () (assign "$" : map setField fields) ]

216 return [ VarDeclStmt () (assign "$" : map setField fields) ]

226

217

227 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

218 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

@@ -230,18 +221,18 @@ definition (Canonical.Definition pattern expr@(A region _) _) = do

230 vars = getVars patterns

221 vars = getVars patterns

231 getVars patterns =

222 getVars patterns =

232 case patterns of

223 case patterns of

233− P.Var x : rest -> (x:) `fmap` getVars rest

224+ P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

234 [] -> Just []

225 [] -> Just []

235 _ -> Nothing

226 _ -> Nothing

236

227

237− decl x n = varDecl x (dotSep ["$","_" ++ show n])

228+ decl x n = varDecl x (obj ["$","_" ++ show n])

238 setup vars

229 setup vars

239 | Help.isTuple name = assign "$" : vars

230 | Help.isTuple name = assign "$" : vars

240 | otherwise = assign "_raw" : safeAssign : vars

231 | otherwise = assign "_raw" : safeAssign : vars

241

232

242− safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)

233+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

243− if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)

234+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

244− exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]

235+ exception = Help.throw "Case" region

245

236

246 _ ->

237 _ ->

247 do defs' <- concat <$> mapM toDef vars

238 do defs' <- concat <$> mapM toDef vars

@@ -265,15 +256,15 @@ match region mtch =

265 _ -> False

256 _ -> False

266

257

267 access name

258 access name

268− | any isLiteral clauses = obj name

259+ | any isLiteral clauses = obj [name]

269− | otherwise = dotSep (split name ++ ["ctor"])

260+ | otherwise = obj (Help.splitDots name ++ ["ctor"])

270

261

271 format isChars e

262 format isChars e

272 | or isChars = InfixExpr () OpAdd e (string "")

263 | or isChars = InfixExpr () OpAdd e (string "")

273 | otherwise = e

264 | otherwise = e

274

265

275 Case.Fail ->

266 Case.Fail ->

276− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]

267+ return [ ExprStmt () (Help.throw "Case" region) ]

277

268

278 Case.Break -> return [BreakStmt () Nothing]

269 Case.Break -> return [BreakStmt () Nothing]

279

270

@@ -314,22 +305,48 @@ generate modul =

314 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

305 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

315 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

306 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

316 where

307 where

308+ names :: [String]

317 names = Module.names modul

309 names = Module.names modul

318

310

311+ thisModule :: Expression ()

319− thisModule = dotSep ("_elm" : names ++ ["values"])

312+ thisModule = obj ("_elm" : names ++ ["values"])

313+

314+ programStmts :: [Statement ()]

320 programStmts =

315 programStmts =

321 concat

316 concat

322− [ [ ExprStmt () $ string "use strict" ]

317+ [ [ ExprStmt () (string "use strict") ]

323 , setup "_elm" (names ++ ["values"])

318 , setup "_elm" (names ++ ["values"])

324 , [ IfSingleStmt () thisModule (ret thisModule) ]

319 , [ IfSingleStmt () thisModule (ret thisModule) ]

325− , [ internalImports (List.intercalate "." names) ]

320+ , [ VarDeclStmt () localVars ]

326− , map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

321+ , body

327− , [ assign ["_op"] (ObjectLit () []) ]

328− , concat $ evalState (mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)) 0

329 , [ jsExports ]

322 , [ jsExports ]

330 , [ ret thisModule ]

323 , [ ret thisModule ]

331 ]

324 ]

332

325

326+ localVars :: [VarDecl ()]

327+ localVars = varDecl "_op" (ObjectLit () []) :

328+ internalImports (Module.getName modul) ++

329+ explicitImports

330+ where

331+ explicitImports :: [VarDecl ()]

332+ explicitImports =

333+ map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

334+

335+ jsImport :: String -> VarDecl ()

336+ jsImport name =

337+ varDecl (Var.moduleName name) $

338+ obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

339+

340+ body :: [Statement ()]

341+ body = concat $ evalState defs 0

342+ where

343+ defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)

344+

345+ setup namespace path = map create paths

346+ where

347+ create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

348+ paths = drop 2 . init . List.inits $ namespace : path

349+

333 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

350 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

334 where

351 where

335 exs = map entry $ "_op" : concatMap extract (exports modul)

352 exs = map entry $ "_op" : concatMap extract (exports modul)

@@ -345,19 +362,11 @@ generate modul =

345 case path of

362 case path of

346 [x] -> VarDeclStmt () [ varDecl x expr ]

363 [x] -> VarDeclStmt () [ varDecl x expr ]

347 _ -> ExprStmt () $

364 _ -> ExprStmt () $

348− AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

365+ AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

349−

350− jsImport name =

351− assign [dolarize name] $ dotSep ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

352−

353− setup namespace path = map create paths

354− where

355− create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

356− paths = drop 2 . init . List.inits $ namespace : path

357

366

358binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

367binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

359 -> State Int (Expression ())

368 -> State Int (Expression ())

360−binop region (Var.Canonical home op) e1 e2 =

369+binop region func@(Var.Canonical home op) e1 e2 =

361 case (home, op) of

370 case (home, op) of

362 (Var.Module "Basics", ".") ->

371 (Var.Module "Basics", ".") ->

363 do es <- mapM expression (e1 : collect [] e2)

372 do es <- mapM expression (e1 : collect [] e2)

@@ -371,7 +380,7 @@ binop region (Var.Canonical home op) e1 e2 =

371 (Var.Module "List", "++") ->

380 (Var.Module "List", "++") ->

372 do e1' <- expression e1

381 do e1' <- expression e1

373 e2' <- expression e2

382 e2' <- expression e2

374− return $ obj "_L.append" `call` [e1', e2']

383+ return $ _List "append" `call` [e1', e2']

375

384

376 (Var.BuiltIn, "::") ->

385 (Var.BuiltIn, "::") ->

377 expression (A region (Data "::" [e1,e2]))

386 expression (A region (Data "::" [e1,e2]))

@@ -381,12 +390,12 @@ binop region (Var.Canonical home op) e1 e2 =

381 e2' <- expression e2

390 e2' <- expression e2

382 return $ case Map.lookup op basicOps of

391 return $ case Map.lookup op basicOps of

383 Just f -> f e1' e2'

392 Just f -> f e1' e2'

384− Nothing -> ref "A2" `call` [ func, e1', e2' ]

393+ Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]

385

394

386 _ ->

395 _ ->

387 do e1' <- expression e1

396 do e1' <- expression e1

388 e2' <- expression e2

397 e2' <- expression e2

389− return (ref "A2" `call` [ func, e1', e2' ])

398+ return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

390

399

391 where

400 where

392 collect es e =

401 collect es e =

@@ -395,14 +404,6 @@ binop region (Var.Canonical home op) e1 e2 =

395 collect (es ++ [e1]) e2

404 collect (es ++ [e1]) e2

396 _ -> es ++ [e]

405 _ -> es ++ [e]

397

406

398− func | Help.isOp op = BracketRef () (dotSep (path ++ ["_op"])) (string op)

399− | otherwise = dotSep (path ++ [op])

400− where

401− path = case home of

402− Var.Local -> []

403− Var.BuiltIn -> []

404− Var.Module m -> [dolarize m]

405−

406 basicOps = Map.fromList (infixOps ++ specialOps)

407 basicOps = Map.fromList (infixOps ++ specialOps)

407

408

408 infixOps =

409 infixOps =

@@ -416,10 +417,10 @@ binop region (Var.Canonical home op) e1 e2 =

416 ]

417 ]

417

418

418 specialOps =

419 specialOps =

419− [ (,) "^" $ \a b -> obj "Math.pow" `call` [a,b]

420+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

420 , (,) "|>" $ flip (<|)

421 , (,) "|>" $ flip (<|)

421− , (,) "==" $ \a b -> obj "_U.eq" `call` [a,b]

422+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

422− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

423+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

423 , (,) "<" $ cmp OpLT 0

424 , (,) "<" $ cmp OpLT 0

424 , (,) ">" $ cmp OpGT 0

425 , (,) ">" $ cmp OpGT 0

425 , (,) "<=" $ cmp OpLT 1

426 , (,) "<=" $ cmp OpLT 1

@@ -427,4 +428,4 @@ binop region (Var.Canonical home op) e1 e2 =

427 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

428 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

428 ]

429 ]

429

430

430− cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

431+ cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hs+41−20

@@ -1,20 +1,11 @@

1{-# OPTIONS_GHC -W #-}

2module Generate.JavaScript.Helpers where

4+import AST.Annotation (Region)

4−import qualified AST.Helpers as Help

5+import qualified AST.PrettyPrint as PP

5import Language.ECMAScript3.Syntax

6import Language.ECMAScript3.Syntax

7−dolarize :: String -> String

8+-- Creating Variables

8−dolarize x = map (\c -> if c == '.' then '$' else c) x

9−

10−split :: String -> [String]

11−split = go []

12− where

13− go vars str =

14− case break (=='.') str of

15− (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

16− | otherwise -> go (vars ++ [x]) rest

17− (x,[]) -> vars ++ [x]

19var :: String -> Id ()

10var :: String -> Id ()

20var name = Id () name

11var name = Id () name

@@ -22,24 +13,54 @@ var name = Id () name

22ref :: String -> Expression ()

13ref :: String -> Expression ()

23ref name = VarRef () (var name)

14ref name = VarRef () (var name)

16+prop :: String -> Prop ()

25prop name = PropId () (var name)

17prop name = PropId () (var name)

26−f <| x = CallExpr () f [x]

18+

27−ret e = ReturnStmt () (Just e)

28−args ==> e = FuncExpr () Nothing (map var args) [ ret e ]

29−function args stmts = FuncExpr () Nothing (map var args) stmts

30−call = CallExpr ()

31string = StringLit ()

19string = StringLit ()

33−dotSep :: [String] -> Expression ()

21+obj :: [String] -> Expression ()

34−dotSep vars =

22+obj vars =

35 case vars of

23 case vars of

36 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

24 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

37 [] -> error "dotSep must be called on a non-empty list of variables"

25 [] -> error "dotSep must be called on a non-empty list of variables"

39−obj = dotSep . split

27+-- Specific Utilities

28+

29+localModuleName :: String

30+localModuleName = "$moduleName"

31+

32+throw :: String -> Region -> Expression ()

33+throw kind region =

34+ obj ["_E",kind] `call` [ ref localModuleName, string (PP.renderPretty region) ]

35+

36+-- Function Calls

37+

38+(<|) :: Expression () -> Expression () -> Expression ()

39+(<|) f x = CallExpr () f [x]

40+

41+ret :: Expression () -> Statement ()

42+ret e = ReturnStmt () (Just e)

43+

44+(==>) :: [String] -> Expression () -> Expression ()

45+(==>) args e = FuncExpr () Nothing (map var args) [ ret e ]

46+

47+function :: [String] -> [Statement ()] -> Expression ()

48+function args stmts = FuncExpr () Nothing (map var args) stmts

49+

50+call :: Expression () -> [Expression ()] -> Expression ()

51+call = CallExpr ()

52+

53+-- Checks

55+equal :: Expression () -> Expression () -> Expression ()

41equal a b = InfixExpr () OpStrictEq a b

56equal a b = InfixExpr () OpStrictEq a b

57+

58+instanceof :: String -> Expression () -> Expression ()

42instanceof tipe x =

59instanceof tipe x =

43 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

60 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61+

62+typeof :: String -> Expression () -> Expression ()

44typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

63typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64+

65+member :: String -> Expression () -> Expression ()

45member field x = InfixExpr () OpIn (string field) x

66member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hs+12−12

@@ -14,13 +14,13 @@ check x jsType continue =

14 CondExpr () (jsFold OpLOr checks x) continue throw

15 where

16 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17− throw = obj "_E.raise" <| InfixExpr () OpAdd msg x

17+ throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x

18 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19 checks = case jsType of

20 JSNumber -> [typeof "number"]

21 JSBoolean -> [typeof "boolean"]

22 JSString -> [typeof "string", instanceof "String"]

23− JSArray -> [(obj "_U.isJSArray" <|)]

23+ JSArray -> [(obj ["_U","isJSArray"] <|)]

24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

26incoming :: CanonicalType -> Expression ()

@@ -29,7 +29,7 @@ incoming tipe =

29 Aliased _ t -> incoming t

31 App (Type v) [t]

32− | Var.isSignal v -> obj "Native.Ports.incomingSignal" <| incoming t

32+ | Var.isSignal v -> obj ["Native","Ports","incomingSignal"] <| incoming t

34 _ -> ["v"] ==> inc tipe (ref "v")

@@ -50,19 +50,19 @@ inc tipe x =

50 from checks = check x checks x

52 Type name

53− | Var.isJson name -> obj "Native.Json.fromJS" <| x

53+ | Var.isJson name -> obj ["Native","Json","fromJS"] <| x

54 | otherwise -> error "bad type got to incoming port generation code"

56 App f args ->

57 case f : args of

58 Type name : [t]

59 | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))

60− (obj "Maybe.Nothing")

60+ (obj ["Maybe","Nothing"])

61− (obj "Maybe.Just" <| inc t x)

61+ (obj ["Maybe","Just"] <| inc t x)

63− | Var.isList name -> check x JSArray (obj "_L.fromArray" <| array)

63+ | Var.isList name -> check x JSArray (obj ["_L","fromArray"] <| array)

65− | Var.isArray name -> check x JSArray (obj "_A.fromJSArray" <| array)

65+ | Var.isArray name -> check x JSArray (obj ["_A","fromJSArray"] <| array)

66 where

67 array = DotRef () x (var "map") <| incoming t

@@ -96,7 +96,7 @@ outgoing tipe =

96 Aliased _ t -> outgoing t

98 App (Type v) [t]

99− | Var.isSignal v -> obj "Native.Ports.outgoingSignal" <| outgoing t

99+ | Var.isSignal v -> obj ["Native","Ports","outgoingSignal"] <| outgoing t

100

101 _ -> ["v"] ==> out tipe (ref "v")

102

@@ -125,7 +125,7 @@ out tipe x =

125 | name `elem` ["Int","Float","Bool","String"] -> x

126

127 Type name

128− | Var.isJson name -> obj "Native.Json.toJS" <| x

128+ | Var.isJson name -> obj ["Native","Json","toJS"] <| x

129 | otherwise -> error "bad type got to outgoing port generation code"

130

131 App f args ->

@@ -137,10 +137,10 @@ out tipe x =

137 (out t (DotRef () x (var "_0")))

138

139 | Var.isArray name ->

140− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

140+ DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

141

142 | Var.isList name ->

143− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

143+ DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

144

145 Type name : ts

146 | Var.isTuple name ->

compiler/Generate/JavaScript/Variable.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# OPTIONS_GHC -W #-}

2+module Generate.JavaScript.Variable where

4+import qualified AST.Helpers as Help

5+import qualified AST.Variable as Var

6+import qualified Data.Set as Set

7+import qualified Generate.JavaScript.Helpers as JS

8+import qualified Language.ECMAScript3.Syntax as JS

10+swap :: Char -> Char -> Char -> Char

11+swap from to c = if c == from then to else c

12+

13+canonical :: Var.Canonical -> JS.Expression ()

14+canonical (Var.Canonical home name) =

15+ case Help.isOp name of

16+ True -> JS.BracketRef () (JS.obj (home' ++ ["_op"])) (JS.string name)

17+ False -> JS.obj (home' ++ [ varName name ])

18+ where

19+ home' =

20+ case home of

21+ Var.Local -> []

22+ Var.BuiltIn -> []

23+ Var.Module path -> [ moduleName path ]

24+

25+moduleName :: String -> String

26+moduleName x = '$' : map (swap '.' '$') x

27+

28+varName :: String -> String

29+varName x = map (swap '\'' '$') x'

30+ where

31+ x' = if Set.member x jsReserveds then '$' : x else x

32+

33+jsReserveds :: Set.Set String

34+jsReserveds = Set.fromList

35+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

36+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

37+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

38+ , "transient", "synchronized", "function", "break", "case", "catch"

39+ , "continue", "debugger", "default", "delete", "do", "else", "finally"

40+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

41+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

42+ , "const", "enum", "export", "extends", "import", "super", "implements"

43+ , "interface", "let", "package", "private", "protected", "public"

44+ , "static", "yield"

45+ -- reserved by the Elm runtime system

46+ , "Elm", "ElmRuntime"

47+ , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

48+ , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

49+ ]

compiler/Parse/Helpers.hs+2−20

@@ -6,7 +6,6 @@ import Control.Applicative ((<$>),(<*>))

6import Control.Monad

7import Control.Monad.State

8import Data.Char (isUpper)

9−import qualified Data.Set as Set

10import qualified Data.Map as Map

9import qualified Data.Map as Map

11import qualified Language.GLSL.Parser as GLP

10import qualified Language.GLSL.Parser as GLP

12import Language.GLSL.Syntax as GLS

11import Language.GLSL.Syntax as GLS

@@ -30,25 +29,8 @@ reserveds = [ "if", "then", "else"

30 , "module", "where"

29 , "module", "where"

31 , "import", "as", "hiding", "open"

30 , "import", "as", "hiding", "open"

32 , "export", "foreign"

31 , "export", "foreign"

33− , "deriving", "port" ]

32+ , "deriving", "port"

34−

35−jsReserveds :: Set.Set String

36−jsReserveds = Set.fromList

37− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

38− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

39− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

40− , "transient", "synchronized", "function", "break", "case", "catch"

41− , "continue", "debugger", "default", "delete", "do", "else", "finally"

42− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

43− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

44− , "const", "enum", "export", "extends", "import", "super", "implements"

45− , "interface", "let", "package", "private", "protected", "public"

46− , "static", "yield"

47− -- reserved by the Elm runtime system

48− , "Elm", "ElmRuntime"

49− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

50− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

51− ]

33+ ]

53expecting = flip (<?>)

35expecting = flip (<?>)