42c3f75 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Get generation of expressions working again

42c3f75Evan Czaplicki9 years ago

src/AST/Module/Name.hs+17−7

compare with master

unifiedsplit

@@ -2,9 +2,10 @@

2{-# LANGUAGE OverloadedStrings #-}

3module AST.Module.Name

4 ( Canonical(..)

5− , basics, char, string, debug

5+ , basics, char, string

6 , maybe, list, array

7− , platform, cmd, sub, virtualDom

7+ , platform, cmd, sub

8+ , virtualDom, debug, bitwise

8 , jsonDecode, jsonEncode

9 , jsonDecode, jsonEncode

9 , webgl, vector2, vector3, vector4, matrix4

10 , webgl, vector2, vector3, vector4, matrix4

10 , canonicalToText

11 , canonicalToText

@@ -59,11 +60,6 @@ string :: Canonical

59string = Canonical Pkg.core N.string

60string = Canonical Pkg.core N.string

62−{-# NOINLINE debug #-}

63−debug :: Canonical

64−debug = Canonical Pkg.core N.debug

65−

66−

68-- CONTAINERS

64-- CONTAINERS

@@ -102,11 +98,25 @@ sub :: Canonical

102sub = Canonical Pkg.core "Platform.Sub"

98sub = Canonical Pkg.core "Platform.Sub"

103

104

100

101+

102+-- MISC

103+

104+

105{-# NOINLINE virtualDom #-}

106virtualDom :: Canonical

107virtualDom = Canonical Pkg.virtualDom "VirtualDom"

108

109

110+{-# NOINLINE debug #-}

111+debug :: Canonical

112+debug = Canonical Pkg.core N.debug

113+

114+

115+{-# NOINLINE bitwise #-}

116+bitwise :: Canonical

117+bitwise = Canonical Pkg.core N.bitwise

118+

119+

110

120

111-- JSON

121-- JSON

112

122

src/Elm/Name.hs+61−3

@@ -2,20 +2,28 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Elm.Name

4 ( Name

5+ , length

5 , toString

6 , toString

7+ , toBuilder

8+ , toShort

6 , localFromInt

9 , localFromInt

7 , toCompositeName

10 , toCompositeName

8 , int, float, bool, char, string

11 , int, float, bool, char, string

9− , maybe, list, array

12+ , maybe, list, array, tuple

10 , task, router, cmd, sub

13 , task, router, cmd, sub

14+ , shader, debug, bitwise, basics

11− , shader, debug, utils, negate, value

15+ , utils, negate, value

16+ , node, program, main, dollar

12 )

17 )

13 where

18 where

16−import Prelude hiding (maybe, negate)

21+import Prelude hiding (length, maybe, negate)

22+import qualified Data.ByteString.Builder as B

23+import qualified Data.ByteString.Short as S

17import qualified Data.Set as Set

24import qualified Data.Set as Set

18import qualified Data.Text as Text

25import qualified Data.Text as Text

26+import qualified Data.Text.Encoding as Text

@@ -25,11 +33,26 @@ import qualified Data.Text as Text

25type Name = Text.Text

33type Name = Text.Text

36+length :: Name -> Int

37+length =

38+ Text.length

39+

40+

28toString :: Name -> String

41toString :: Name -> String

29toString =

42toString =

30 Text.unpack

43 Text.unpack

46+toBuilder :: Name -> B.Builder

47+toBuilder =

48+ Text.encodeUtf8Builder

49+

50+

51+toShort :: Name -> S.ShortByteString

52+toShort =

53+ error "TODO"

54+

55+

33localFromInt :: Int -> Name

56localFromInt :: Int -> Name

34localFromInt n =

57localFromInt n =

35 Text.pack ('x' : show n)

58 Text.pack ('x' : show n)

@@ -84,6 +107,11 @@ array :: Name

84array = "Array"

107array = "Array"

108

109

110+{-# NOINLINE tuple #-}

111+tuple :: Name

112+tuple = "Tuple"

113+

114+

87{-# NOINLINE task #-}

115{-# NOINLINE task #-}

88task :: Name

116task :: Name

89task = "Task"

117task = "Task"

@@ -114,6 +142,16 @@ debug :: Name

114debug = "Debug"

142debug = "Debug"

115

143

116

144

145+{-# NOINLINE bitwise #-}

146+bitwise :: Name

147+bitwise = "Bitwise"

148+

149+

150+{-# NOINLINE basics #-}

151+basics :: Name

152+basics = "Basics"

153+

154+

117{-# NOINLINE utils #-}

155{-# NOINLINE utils #-}

118utils :: Name

156utils :: Name

119utils = "Utils"

157utils = "Utils"

@@ -127,3 +165,23 @@ negate = "negate"

127{-# NOINLINE value #-}

165{-# NOINLINE value #-}

128value :: Name

166value :: Name

129value = "Value"

167value = "Value"

168+

169+

170+{-# NOINLINE node #-}

171+node :: Name

172+node = "Node"

173+

174+

175+{-# NOINLINE program #-}

176+program :: Name

177+program = "Program"

178+

179+

180+{-# NOINLINE main #-}

181+main :: Name

182+main = "main"

183+

184+

185+{-# NOINLINE dollar #-}

186+dollar :: Name

187+dollar = "$"

src/Generate/JavaScript/Builder.hs+43−66

@@ -3,8 +3,8 @@

3module Generate.JavaScript.Builder

4 ( stmtToBuilder

5 , exprToBuilder

6− , Expr(..), Id(..), LValue(..)

6+ , Expr(..), LValue(..)

7− , Stmt(..), Case(..), VarDecl(..)

7+ , Stmt(..), Case(..)

8 , InfixOp(..), PrefixOp(..)

9 )

10 where

@@ -16,10 +16,10 @@ module Generate.JavaScript.Builder

17import Prelude hiding (lines)

18import qualified Data.List as List

19−import Data.ByteString.Builder

19+import Data.ByteString.Builder as B

20import Data.Monoid ((<>))

21−import Data.Text (Text)

21+import qualified Generate.JavaScript.Name as Name

22−import qualified Data.Text.Encoding as Text

22+import Generate.JavaScript.Name (Name)

@@ -27,30 +27,27 @@ import qualified Data.Text.Encoding as Text

29data Expr

30− = String Text

30+ = String Builder

31 | Float Double

32 | Int Int

33 | Bool Bool

34 | Null

35 | Array [Expr]

36− | Object [(Id, Expr)]

36+ | Object [(Name, Expr)]

37− | VarRef Id

37+ | Ref Name

38− | DotRef Expr Id -- ^ @foo.bar@, spec 11.2.1

38+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1

39− | BracketRef Expr Expr -- ^ @foo[bar]@, spec 11.2.1

39+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1

40 | Prefix PrefixOp Expr

41 | Infix InfixOp Expr Expr

42 | If Expr Expr Expr

43 | Assign LValue Expr

44 | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3

45− | Function (Maybe Id) [Id] [Stmt]

45+ | Function (Maybe Name) [Name] [Stmt]

46−

47−

48−newtype Id = Id Text

51data LValue

48data LValue

52− = LVar Text

49+ = LVar Name

53− | LDot Expr Text

50+ | LDot Expr Name

54 | LBracket Expr Expr

51 | LBracket Expr Expr

@@ -63,16 +60,15 @@ data Stmt

63 | EmptyStmt -- ;

60 | EmptyStmt -- ;

64 | ExprStmt Expr -- expr;

61 | ExprStmt Expr -- expr;

65 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2

62 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2

66− | IfSingleStmt Expr Stmt -- if (e) stmt

67 | Switch Expr [Case] -- switch (e) clauses

63 | Switch Expr [Case] -- switch (e) clauses

68 | While Expr Stmt -- while (e) do stmt

64 | While Expr Stmt -- while (e) do stmt

69 | DoWhile Stmt Expr -- do stmt while (e);

65 | DoWhile Stmt Expr -- do stmt while (e);

70− | Break (Maybe Id) -- break lab;

66+ | Break (Maybe Name) -- break lab;

71− | Continue (Maybe Id) -- continue lab;

67+ | Continue (Maybe Name) -- continue lab;

72− | Labelled Id Stmt -- lab: stmt

68+ | Labelled Name Stmt -- lab: stmt

73 | Return (Maybe Expr) -- return expr;

69 | Return (Maybe Expr) -- return expr;

74− | VarDeclStmt [VarDecl] -- var x, y=42;

70+ | Var [(Name, Maybe Expr)] -- var x, y=42;

75− | FunctionStmt Id [Id] [Stmt] -- function f(x, y, z) {...}

71+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}

78data Case

74data Case

@@ -80,9 +76,6 @@ data Case

80 | Default [Stmt]

76 | Default [Stmt]

83−data VarDecl = VarDecl Id (Maybe Expr)

84−

85−

87-- OPERATORS

80-- OPERATORS

@@ -184,13 +177,6 @@ fromStmt indent statement =

184 , indent, "}\n"

177 , indent, "}\n"

185 ]

178 ]

186

179

187− IfSingleStmt condition thenStmt ->

188− mconcat

189− [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

190− , fromStmt (deeper indent) thenStmt

191− , indent, "}\n"

192− ]

193−

194 Switch expr clauses ->

180 Switch expr clauses ->

195 mconcat

181 mconcat

196 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

182 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

@@ -216,17 +202,17 @@ fromStmt indent statement =

216 indent <> "break;\n"

202 indent <> "break;\n"

217

203

218 Break (Just label) ->

204 Break (Just label) ->

219− indent <> "break " <> fromId label <> ";\n"

205+ indent <> "break " <> Name.toBuilder label <> ";\n"

220

206

221 Continue Nothing ->

207 Continue Nothing ->

222 indent <> "continue;\n"

208 indent <> "continue;\n"

223

209

224 Continue (Just label) ->

210 Continue (Just label) ->

225− indent <> "continue " <> fromId label <> ";\n"

211+ indent <> "continue " <> Name.toBuilder label <> ";\n"

226

212

227 Labelled label stmt ->

213 Labelled label stmt ->

228 mconcat

214 mconcat

229− [ indent, fromId label, ":\n"

215+ [ indent, Name.toBuilder label, ":\n"

230 , fromStmt indent stmt

216 , fromStmt indent stmt

231 ]

217 ]

232

218

@@ -236,14 +222,14 @@ fromStmt indent statement =

236 Return (Just expr) ->

222 Return (Just expr) ->

237 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

223 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

238

224

239− VarDeclStmt [] ->

225+ Var [] ->

240 mempty

226 mempty

241

227

242− VarDeclStmt decls ->

228+ Var vars ->

243− indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"

229+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"

244

230

245 FunctionStmt name args stmts ->

231 FunctionStmt name args stmts ->

246− indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"

232+ indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

247 <>

233 <>

248 fromStmtBlock (deeper indent) stmts

234 fromStmtBlock (deeper indent) stmts

249 <>

235 <>

@@ -267,26 +253,17 @@ fromClause indent clause =

267

253

268

254

269

255

270−-- ID

271−

272−

273−fromId :: Id -> Builder

274−fromId (Id name) =

275− Text.encodeUtf8Builder name

276−

277−

278−

279-- VAR DECLS

256-- VAR DECLS

280

257

281

258

282−fromVarDecl :: Builder -> VarDecl -> Builder

259+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder

283−fromVarDecl indent (VarDecl (Id name) maybeExpr) =

260+varToBuilder indent (name, maybeExpr) =

284 case maybeExpr of

261 case maybeExpr of

285 Nothing ->

262 Nothing ->

286− Text.encodeUtf8Builder name

263+ Name.toBuilder name

287

264

288 Just expr ->

265 Just expr ->

289− Text.encodeUtf8Builder name <> " = " <> snd (fromExpr indent Whatever expr)

266+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)

290

267

291

268

292

269

@@ -329,13 +306,13 @@ fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)

329fromExpr indent grouping expression =

306fromExpr indent grouping expression =

330 case expression of

307 case expression of

331 String string ->

308 String string ->

332− (One, "'" <> Text.encodeUtf8Builder string <> "'")

309+ (One, "'" <> string <> "'")

333

310

334 Float n ->

311 Float n ->

335− (One, doubleDec n)

312+ (One, B.doubleDec n)

336

313

337 Int n ->

314 Int n ->

338− (One, intDec n)

315+ (One, B.intDec n)

339

316

340 Bool bool ->

317 Bool bool ->

341 (One, if bool then "true" else "false")

318 (One, if bool then "true" else "false")

@@ -376,13 +353,13 @@ fromExpr indent grouping expression =

376 else

353 else

377 "{" <> commaSep builders <> "}"

354 "{" <> commaSep builders <> "}"

378

355

379− VarRef name ->

356+ Ref name ->

380− (One, fromId name)

357+ (One, Name.toBuilder name)

381

358

382− DotRef expr (Id name) ->

359+ Access expr field ->

383− makeDot indent expr name

360+ makeDot indent expr field

384

361

385− BracketRef expr bracketedExpr ->

362+ Index expr bracketedExpr ->

386 makeBracketed indent expr bracketedExpr

363 makeBracketed indent expr bracketedExpr

387

364

388 Prefix op expr ->

365 Prefix op expr ->

@@ -448,7 +425,7 @@ fromExpr indent grouping expression =

448

425

449 Function maybeName args stmts ->

426 Function maybeName args stmts ->

450 (,) Many $

427 (,) Many $

451− "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"

428+ "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

452 <>

429 <>

453 fromStmtBlock (deeper indent) stmts

430 fromStmtBlock (deeper indent) stmts

454 <>

431 <>

@@ -459,14 +436,14 @@ fromExpr indent grouping expression =

459-- FIELDS

436-- FIELDS

460

437

461

438

462−fromField :: Builder -> (Id, Expr) -> (Lines, Builder)

439+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)

463fromField indent (field, expr) =

440fromField indent (field, expr) =

464 let

441 let

465 (lines, builder) =

442 (lines, builder) =

466 fromExpr indent Whatever expr

443 fromExpr indent Whatever expr

467 in

444 in

468 ( lines

445 ( lines

469− , fromId field <> ": " <> builder

446+ , Name.toBuilder field <> ": " <> builder

470 )

447 )

471

448

472

449

@@ -478,7 +455,7 @@ fromLValue :: Builder -> LValue -> (Lines, Builder)

478fromLValue indent lValue =

455fromLValue indent lValue =

479 case lValue of

456 case lValue of

480 LVar name ->

457 LVar name ->

481− (One, Text.encodeUtf8Builder name)

458+ (One, Name.toBuilder name)

482

459

483 LDot expr field ->

460 LDot expr field ->

484 makeDot indent expr field

461 makeDot indent expr field

@@ -487,13 +464,13 @@ fromLValue indent lValue =

487 makeBracketed indent expr bracketedExpr

464 makeBracketed indent expr bracketedExpr

488

465

489

466

490−makeDot :: Builder -> Expr -> Text -> (Lines, Builder)

467+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)

491makeDot indent expr field =

468makeDot indent expr field =

492 let

469 let

493 (lines, builder) =

470 (lines, builder) =

494 fromExpr indent Atomic expr

471 fromExpr indent Atomic expr

495 in

472 in

496− (lines, builder <> "." <> Text.encodeUtf8Builder field)

473+ (lines, builder <> "." <> Name.toBuilder field)

497

474

498

475

499makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)

476makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)

src/Generate/JavaScript/Expression.hs+593−422

@@ -1,70 +1,171 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Generate.JavaScript.Expression

3− ( generateDecl

3+ ( generateJsExpr

4 )

5 where

7−import Prelude hiding (exp)

8−import Control.Arrow (second)

8+import qualified Data.IntMap as IntMap

9−import Control.Monad (foldM)

10import qualified Data.List as List

9import qualified Data.List as List

11import qualified Data.Map as Map

10import qualified Data.Map as Map

12−import Data.Monoid ((<>))

13−import qualified Data.Text as Text

11+import qualified Data.Text.Encoding as Text

14−import Data.Text (Text)

16−import AST.Expression.Optimized as Opt

13+import qualified AST.Optimized as Opt

17−import qualified AST.Literal as L

18import qualified AST.Module.Name as ModuleName

14import qualified AST.Module.Name as ModuleName

19−import qualified AST.Variable as V

15+import qualified Data.Index as Index

20−import Generate.JavaScript.Helpers as Help

16+import qualified Elm.Name as N

17+import qualified Elm.Package as Pkg

21import qualified Generate.JavaScript.Builder as JS

18import qualified Generate.JavaScript.Builder as JS

22−import qualified Generate.JavaScript.BuiltIn as BuiltIn

19+import qualified Generate.JavaScript.Name as Name

23−import qualified Generate.JavaScript.Literal as Literal

24−import qualified Generate.JavaScript.Variable as Var

25−import Generate.JavaScript.Variable (Generator)

26import qualified Optimize.DecisionTree as DT

20import qualified Optimize.DecisionTree as DT

21+import qualified Reporting.Region as R

30−-- GENERATE DECLARATION

25+-- ENVIRONMENT

33−generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt

28+type Mode = Name.Mode

34−generateDecl home name def =

35− do jsName <- Var.globalName (V.Global home name)

36− jsBody <- generateDef name def

37− return $ JS.VarDeclStmt [ Help.varDecl jsName jsBody ]

41−-- CODE CHUNKS

32+-- EXPRESSIONS

44−data Code

35+generateJsExpr :: Mode -> Opt.Expr -> JS.Expr

45− = JsExpr JS.Expr

36+generateJsExpr mode expression =

46− | JsBlock [JS.Stmt]

37+ codeToJsExpr (generateCode mode expression)

49−jsExpr :: JS.Expr -> Generator Code

40+generateCode :: Mode -> Opt.Expr -> Code

50−jsExpr exp =

41+generateCode mode expression =

51− return (JsExpr exp)

42+ case expression of

43+ Opt.Chr char ->

44+ JsExpr $

45+ case mode of

46+ Name.Debug ->

47+ JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]

49+ Name.Prod _ ->

50+ JS.String (Text.encodeUtf8Builder char)

54−jsBlock :: [JS.Stmt] -> Generator Code

52+ Opt.Str string ->

55−jsBlock stmts =

53+ JsExpr $ JS.String (Text.encodeUtf8Builder string)

56− return (JsBlock stmts)

55+ Opt.Int int ->

56+ JsExpr $ JS.Int int

59−isBlock :: Code -> Bool

58+ Opt.Float float ->

60−isBlock code =

59+ JsExpr $ JS.Float float

60+

61+ Opt.VarLocal name ->

62+ JsExpr $ JS.Ref (Name.fromLocal name)

63+

64+ Opt.VarGlobal (Opt.Global home name) ->

65+ JsExpr $ JS.Ref (Name.fromGlobal home name)

66+

67+ Opt.VarCycle home name ->

68+ JsExpr $ JS.Ref (Name.fromCycle home name)

69+

70+ Opt.VarDebug name home region unhandledValueName ->

71+ JsExpr $ generateDebug name home region unhandledValueName

72+

73+ Opt.VarKernel home name ->

74+ JsExpr $ JS.Ref (Name.fromKernel home name)

75+

76+ Opt.List entries ->

77+ JsExpr $

78+ JS.Call

79+ (JS.Ref (Name.fromKernel N.list "fromArray"))

80+ [ JS.Array $ map (generateJsExpr mode) entries

81+ ]

82+

83+ Opt.Function args body ->

84+ generateFunction args (generateCode mode body)

85+

86+ Opt.Call func args ->

87+ JsExpr $ generateCall mode func args

88+

89+ Opt.TailCall name args ->

90+ JsBlock $ generateTailCall mode name args

91+

92+ Opt.If branches final ->

93+ generateIf mode branches final

94+

95+ Opt.Let def body ->

96+ JsBlock $

97+ generateDef mode def : codeToStatementList (generateCode mode body)

98+

99+ Opt.Case label root decider jumps ->

100+ JsBlock $ generateCase mode label root decider jumps

101+

102+ Opt.Index expr index ->

103+ JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)

104+

105+ Opt.Accessor field ->

106+ JsExpr $ JS.Function Nothing [Name.dollar]

107+ [ JS.Return $ Just $

108+ JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)

109+ ]

110+

111+ Opt.Access record field ->

112+ JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)

113+

114+ Opt.Update record fields ->

115+ JsExpr $

116+ JS.Call (JS.Ref (Name.fromKernel N.utils "update"))

117+ [ generateJsExpr mode record

118+ , generateRecord mode fields

119+ ]

120+

121+ Opt.Record fields ->

122+ JsExpr $ generateRecord mode fields

123+

124+ Opt.Unit ->

125+ JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")

126+

127+ Opt.Tuple a b maybeC ->

128+ JsExpr $

129+ case maybeC of

130+ Nothing ->

131+ JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))

132+ [ generateJsExpr mode a

133+ , generateJsExpr mode b

134+ ]

135+

136+ Just c ->

137+ JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))

138+ [ generateJsExpr mode a

139+ , generateJsExpr mode b

140+ , generateJsExpr mode c

141+ ]

142+

143+ Opt.Shader src ->

144+ let string = JS.String (Text.encodeUtf8Builder src) in

145+ JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]

146+

147+

148+

149+-- CODE CHUNKS

150+

151+

152+data Code

153+ = JsExpr JS.Expr

154+ | JsBlock [JS.Stmt]

155+

156+

157+codeToJsExpr :: Code -> JS.Expr

158+codeToJsExpr code =

61 case code of

159 case code of

160+ JsExpr expr ->

161+ expr

162+

62− JsBlock _ -> True

163+ JsBlock stmts ->

63− JsExpr _ -> False

164+ JS.Call (JS.Function Nothing [] stmts) []

165

166

66−toStatementList :: Code -> [JS.Stmt]

167+codeToStatementList :: Code -> [JS.Stmt]

67−toStatementList code =

168+codeToStatementList code =

68 case code of

169 case code of

69 JsExpr expr ->

170 JsExpr expr ->

70 [ JS.Return (Just expr) ]

171 [ JS.Return (Just expr) ]

@@ -73,8 +174,8 @@ toStatementList code =

73 stmts

174 stmts

175

176

76−toStatement :: Code -> JS.Stmt

177+codeToStatement :: Code -> JS.Stmt

77−toStatement code =

178+codeToStatement code =

78 case code of

179 case code of

79 JsExpr expr ->

180 JsExpr expr ->

80 JS.Return (Just expr)

181 JS.Return (Just expr)

@@ -86,533 +187,603 @@ toStatement code =

86 JS.Block stmts

187 JS.Block stmts

188

189

89−toExpr :: Code -> JS.Expr

90−toExpr code =

91− case code of

92− JsExpr expr ->

93− expr

190

95− JsBlock stmts ->

191+-- CHARS

96− JS.Call (function [] stmts) []

192

193

99−

194+{-# NOINLINE toChar #-}

100−-- EXPRESSIONS

195+toChar :: JS.Expr

196+toChar =

197+ JS.Ref (Name.fromKernel N.utils "chr")

101

198

102

199

103−generateJsExpr :: Opt.Expr -> Generator JS.Expr

104−generateJsExpr optExpr =

105− toExpr <$> generateCode optExpr

106

200

201+-- RECORDS

107

202

108−generateCode :: Opt.Expr -> Generator Code

109−generateCode expr =

110− case expr of

111− VarLocal name ->

112− jsExpr $ Var.local name

113

203

114− VarGlobal name ->

204+generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr

115− JsExpr <$> Var.global name

205+generateRecord mode fields =

206+ let

207+ toPair (field, value) =

208+ (Name.fromField mode field, generateJsExpr mode value)

209+ in

210+ JS.Object (map toPair (Map.toList fields))

116

211

117− Literal lit ->

118− JsExpr <$> Literal.literal lit

119

212

120− Access record field ->

121− do jsRecord <- generateJsExpr record

122− jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))

123

213

124− Update record fields ->

214+-- DEBUG

125− let

126− fieldToJs (field, value) =

127− do jsValue <- generateJsExpr value

128− return (Var.safe field, jsValue)

129− in

130− do jsRecord <- generateJsExpr record

131− jsFields <- mapM fieldToJs fields

132− JsExpr <$> BuiltIn.recordUpdate jsRecord jsFields

133

215

134− Record fields ->

135− let

136− toField (field, value) =

137− do jsValue <- generateJsExpr value

138− return (Var.safe field ==> jsValue)

139− in

140− do jsFields <- mapM toField fields

141− jsExpr $ JS.Object jsFields

142

216

143− Binop op leftExpr rightExpr ->

217+generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr

144− generateBinop op leftExpr rightExpr

218+generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =

219+ if name /= "crash" then

220+ JS.Ref (Name.fromGlobal ModuleName.debug name)

221+ else

222+ case unhandledValueName of

223+ Nothing ->

224+ JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $

225+ [ JS.String (N.toBuilder home)

226+ , regionToJsExpr region

227+ ]

145

228

146− Function args body ->

229+ Just valueName ->

147− generateFunction args body

230+ JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $

231+ [ JS.String (N.toBuilder home)

232+ , regionToJsExpr region

233+ , JS.Ref (Name.fromLocal valueName)

234+ ]

148

235

149− Call func args ->

150− generateCall func args

151

236

152− TailCall name argNames args ->

237+regionToJsExpr :: R.Region -> JS.Expr

153− let

238+regionToJsExpr (R.Region start end) =

154− reassign argName tempName =

239+ JS.Object

155− JS.ExprStmt $

240+ [ ( Name.fromLocal "start", positionToJsExpr start )

156− JS.Assign (JS.LVar (Var.safe argName)) (ref tempName)

241+ , ( Name.fromLocal "end", positionToJsExpr end )

157− in

242+ ]

158− do args' <- mapM generateJsExpr args

159− tempNames <- mapM (\_ -> Var.fresh) args

160− jsBlock $

161− JS.VarDeclStmt (zipWith varDecl tempNames args')

162− : zipWith reassign argNames tempNames

163− ++ [JS.Continue (Just (JS.Id (Var.safe name)))]

164

243

165− Let defs body ->

166− do stmts <- mapM generateLetDef defs

167− code <- generateCode body

168− jsBlock (stmts ++ toStatementList code)

169

244

170− If branches finally ->

245+positionToJsExpr :: R.Position -> JS.Expr

171− generateIf branches finally

246+positionToJsExpr (R.Position line column) =

247+ JS.Object

248+ [ ( Name.fromLocal "line", JS.Int line )

249+ , ( Name.fromLocal "column", JS.Int column )

250+ ]

172

251

173− Case exprName decider jumps ->

174− JsBlock <$> generateCase exprName decider jumps

175

252

176− List elements ->

177− do jsElements <- mapM generateJsExpr elements

178− JsExpr <$> BuiltIn.list jsElements

179

253

180− Ctor tag members ->

254+-- FUNCTION

181− let

182− tagField =

183− "$" ==> JS.String tag

184

255

185− toEntry entry n =

186− (Help.toFieldName n) ==> entry

187− in

188− do jsMembers <- mapM generateJsExpr members

189− jsExpr $ JS.Object (tagField : zipWith toEntry jsMembers [ 0 :: Int .. ])

190

256

191− CtorAccess dataExpr index ->

257+generateFunction :: [N.Name] -> Code -> Code

192− do jsDataExpr <- generateJsExpr dataExpr

258+generateFunction args body =

193− jsExpr $ JS.DotRef jsDataExpr (JS.Id (Help.toFieldName index))

259+ case IntMap.lookup (length args) funcHelpers of

260+ Just helper ->

261+ JsExpr $

262+ JS.Call helper

263+ [ JS.Function Nothing (map Name.fromLocal args) $

264+ codeToStatementList body

265+ ]

266+

267+ Nothing ->

268+ let

269+ addArg arg code =

270+ JsExpr $ JS.Function Nothing [Name.fromLocal arg] $

271+ codeToStatementList code

272+ in

273+ foldr addArg body args

274+

275+

276+{-# NOINLINE funcHelpers #-}

277+funcHelpers :: IntMap.IntMap JS.Expr

278+funcHelpers =

279+ IntMap.fromList

280+ [ (2, JS.Ref (Name.fromLocal "F2"))

281+ , (3, JS.Ref (Name.fromLocal "F3"))

282+ , (4, JS.Ref (Name.fromLocal "F4"))

283+ , (5, JS.Ref (Name.fromLocal "F5"))

284+ , (6, JS.Ref (Name.fromLocal "F6"))

285+ , (7, JS.Ref (Name.fromLocal "F7"))

286+ , (8, JS.Ref (Name.fromLocal "F8"))

287+ , (9, JS.Ref (Name.fromLocal "F9"))

288+ ]

194

289

195− Cmd moduleName _ ->

196− JsExpr <$> BuiltIn.effect moduleName

197

290

198− Sub moduleName _ ->

199− JsExpr <$> BuiltIn.effect moduleName

200

291

201− OutgoingPort name encoder ->

292+-- CALLS

202− do jsEncoder <- generateJsExpr encoder

203− JsExpr <$> BuiltIn.outgoingPort name jsEncoder

204

293

205− IncomingPort name decoder ->

206− do jsDecoder <- generateJsExpr decoder

207− JsExpr <$> BuiltIn.incomingPort name jsDecoder

208

294

209− Program kind body ->

295+generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

210− generateProgram kind body

296+generateCall mode func args =

297+ case func of

298+ Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->

299+ generateCoreCall mode global args

211

300

212− GLShader src ->

301+ _ ->

213− do string <- Literal.literal (L.Str src)

302+ generateNormalCall

214− jsExpr $ JS.Object [(JS.StringProp "src", string)]

303+ (generateJsExpr mode func)

304+ (map (generateJsExpr mode) args)

305+

306+

307+generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

308+generateNormalCall' home name args =

309+ generateNormalCall (JS.Ref (Name.fromGlobal home name)) args

310+

311+

312+generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr

313+generateNormalCall func args =

314+ case IntMap.lookup (length args) callHelpers of

315+ Just helper ->

316+ JS.Call helper (func:args)

317+

318+ Nothing ->

319+ List.foldl' (\f a -> JS.Call f [a]) func args

320+

321+

322+{-# NOINLINE callHelpers #-}

323+callHelpers :: IntMap.IntMap JS.Expr

324+callHelpers =

325+ IntMap.fromList

326+ [ (2, JS.Ref (Name.fromLocal "A2"))

327+ , (3, JS.Ref (Name.fromLocal "A3"))

328+ , (4, JS.Ref (Name.fromLocal "A4"))

329+ , (5, JS.Ref (Name.fromLocal "A5"))

330+ , (6, JS.Ref (Name.fromLocal "A6"))

331+ , (7, JS.Ref (Name.fromLocal "A7"))

332+ , (8, JS.Ref (Name.fromLocal "A8"))

333+ , (9, JS.Ref (Name.fromLocal "A9"))

334+ ]

215

335

216− Crash home region maybeBranchProblem ->

217− do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem

218− JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem

219

336

220

337

338+-- CORE CALLS

221

339

222−-- PROGRAMS

223

340

341+generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr

342+generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =

343+ if moduleName == N.basics then

344+ generateBasicsCall mode home name args

224

345

225−generateProgram :: Opt.Main -> Opt.Expr -> Generator Code

346+ else if moduleName == N.bitwise then

226−generateProgram kind body =

347+ generateBitwiseCall home name (map (generateJsExpr mode) args)

227− case kind of

228− Opt.Static ->

229− do html <- generateJsExpr body

230− func <- BuiltIn.staticProgram

231− jsExpr (func <| html)

232

348

233− Opt.Dynamic decoder ->

349+ else if moduleName == N.tuple then

234− do almostProgram <- generateJsExpr body

350+ generateTupleCall home name (map (generateJsExpr mode) args)

235− flagDecoder <- generateJsExpr decoder

236− jsExpr (almostProgram <| flagDecoder)

237

351

352+ else

353+ generateNormalCall' home name (map (generateJsExpr mode) args)

238

354

239

355

240−-- DEFINITIONS

356+generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

357+generateTupleCall home name args =

358+ case args of

359+ [value] ->

360+ case name of

361+ "first" -> JS.Access value (Name.fromLocal "a")

362+ "second" -> JS.Access value (Name.fromLocal "b")

363+ _ -> generateNormalCall' home name args

241

364

365+ _ ->

366+ generateNormalCall' home name args

242

367

243−generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt

244−generateLetDef (name, def) =

245− do jsBody <- generateDef name def

246− return $ JS.VarDeclStmt [ Help.varDecl (Var.safe name) jsBody ]

247

368

369+generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

370+generateBitwiseCall home name args =

371+ case args of

372+ [arg] ->

373+ case name of

374+ "complement" -> JS.Prefix JS.PrefixBNot arg

375+ _ -> generateNormalCall' home name args

248

376

249−generateDef :: Text -> Opt.Def -> Generator JS.Expr

377+ [left,right] ->

250−generateDef name def =

251− case def of

378+ case name of

252− Opt.TailDef argNames body ->

379+ "and" -> JS.Infix JS.OpBAnd left right

253− generateTailFunction name argNames body

380+ "or" -> JS.Infix JS.OpBOr left right

381+ "xor" -> JS.Infix JS.OpBXor left right

382+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left

383+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

384+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

385+ _ -> generateNormalCall' home name args

254

386

255− Opt.Def body ->

387+ _ ->

256− generateJsExpr body

388+ generateNormalCall' home name args

257

389

258

390

259−generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr

391+generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr

260−generateTailFunction name args body =

392+generateBasicsCall mode home name args =

261− do code <- generateCode body

393+ case args of

262− return $ generateFunctionWithArity args $ JsBlock $ (:[]) $

394+ [elmArg] ->

263− JS.Labelled

395+ let arg = generateJsExpr mode elmArg in

264− (JS.Id (Var.safe name))

396+ case name of

265− (JS.While (JS.Bool True) (toStatement code))

397+ "not" -> JS.Prefix JS.PrefixLNot arg

398+ "toFloat" -> arg

399+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

400+ _ -> generateNormalCall' home name [arg]

266

401

402+ [elmLeft, elmRight] ->

403+ case name of

404+ "composeL" -> decomposeL mode elmLeft [elmRight]

405+ "composeR" -> decomposeR mode [elmLeft] elmRight

406+ "apL" -> generateJsExpr mode $ apply elmLeft elmRight

407+ "apR" -> generateJsExpr mode $ apply elmRight elmLeft

408+ _ ->

409+ let

410+ left = generateJsExpr mode elmLeft

411+ right = generateJsExpr mode elmRight

412+ in

413+ case name of

414+ "add" -> JS.Infix JS.OpAdd left right

415+ "sub" -> JS.Infix JS.OpSub left right

416+ "mul" -> JS.Infix JS.OpMul left right

417+ "fdiv" -> JS.Infix JS.OpDiv left right

418+ "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

419+ "eq" -> equal left right

420+ "neq" -> notEqual left right

421+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right

422+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right

423+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right

424+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right

425+ "or" -> JS.Infix JS.OpLOr left right

426+ "and" -> JS.Infix JS.OpLAnd left right

427+ "xor" -> JS.Infix JS.OpStrictNEq left right

428+ _ -> generateNormalCall' home name [left, right]

267

429

430+ _ ->

431+ generateNormalCall' home name (map (generateJsExpr mode) args)

268

432

269−-- FUNCTIONS

270

433

434+equal :: JS.Expr -> JS.Expr -> JS.Expr

435+equal left right =

436+ if isLiteral left || isLiteral right then

437+ strictEq left right

438+ else

439+ JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]

271

440

272−generateFunction :: [Text] -> Opt.Expr -> Generator Code

273−generateFunction args body =

274− do code <- generateCode body

275− jsExpr (generateFunctionWithArity args code)

276

441

442+notEqual :: JS.Expr -> JS.Expr -> JS.Expr

443+notEqual left right =

444+ if isLiteral left || isLiteral right then

445+ strictNEq left right

446+ else

447+ JS.Prefix JS.PrefixLNot $

448+ JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]

277

449

278−generateFunctionWithArity :: [Text] -> Code -> JS.Expr

279−generateFunctionWithArity rawArgs code =

280− let

281− args = map Var.safe rawArgs

282− arity = length args

283− in

284− if 2 <= arity && arity <= 9 then

285− let

286− fN = "F" <> Text.pack (show arity)

287− in

288− ref fN <| function args (toStatementList code)

289− else

290− let

291− (lastArg:otherArgs) = reverse args

292− innerBody = function [lastArg] (toStatementList code)

293− in

294− foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs

295

450

451+cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr

452+cmp idealOp backupOp backupInt left right =

453+ if isLiteral left || isLiteral right then

454+ JS.Infix idealOp left right

455+ else

456+ JS.Infix backupOp

457+ (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])

458+ (JS.Int backupInt)

296

459

297

460

298−-- GENERATE CALL

461+isLiteral :: JS.Expr -> Bool

462+isLiteral expr =

463+ case expr of

464+ JS.String _ ->

465+ True

299

466

467+ JS.Float _ ->

468+ True

300

469

301−generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code

470+ JS.Int _ ->

302−generateCall func args =

471+ True

303− case (func, args) of

304− (Opt.VarGlobal (V.Global home name), [arg]) ->

305− case name of

306− "complement" | home == bitwise -> genPrefix JS.PrefixBNot arg

307− "not" | home == basics -> genPrefix JS.PrefixLNot arg

308− _ -> generateCallHelp func args

309

472

310− (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->

473+ JS.Bool _ ->

311− case name of

474+ True

312− "and" -> genInfix JS.OpBAnd left right

313− "or" -> genInfix JS.OpBOr left right

314− "xor" -> genInfix JS.OpBXor left right

315− "shiftLeftBy" -> genInfix JS.OpLShift right left

316− "shiftRightBy" -> genInfix JS.OpSpRShift right left

317− "shiftRightZfBy" -> genInfix JS.OpZfRShift right left

318− _ -> generateCallHelp func args

319

475

320 _ ->

476 _ ->

321− generateCallHelp func args

477+ False

322

478

323

479

324−genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code

480+decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

325−genPrefix op arg =

481+decomposeL mode expr funcs =

326− do jsArg <- generateJsExpr arg

482+ case expr of

327− jsExpr (JS.Prefix op jsArg)

483+ Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]

484+ | home == ModuleName.basics ->

485+ decomposeL mode left (func:funcs)

328

486

487+ _ ->

488+ generateJsExpr mode $

489+ Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))

329

490

330−genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code

331−genInfix op left right =

332− do jsLeft <- generateJsExpr left

333− jsRight <- generateJsExpr right

334− jsExpr $ JS.Infix op jsLeft jsRight

335

491

492+decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr

493+decomposeR mode funcs expr =

494+ case expr of

495+ Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]

496+ | home == ModuleName.basics ->

497+ decomposeR mode (func:funcs) right

336

498

337−basics :: ModuleName.Canonical

499+ _ ->

338−basics =

500+ generateJsExpr mode $

339− ModuleName.inCore "Basics"

501+ Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))

340

502

341

503

342−bitwise :: ModuleName.Canonical

504+apply :: Opt.Expr -> Opt.Expr -> Opt.Expr

343−bitwise =

505+apply func value =

344− ModuleName.inCore "Bitwise"

506+ case func of

507+ Opt.Accessor field ->

508+ Opt.Access value field

345

509

510+ Opt.Call f args ->

511+ Opt.Call f (args ++ [value])

346

512

347−generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code

513+ _ ->

348−generateCallHelp func args =

514+ Opt.Call func [value]

349− let

350− arity = length args

351− aN = "A" <> Text.pack (show arity)

352− in

353− do jsFunc <- generateJsExpr func

354− jsArgs <- mapM generateJsExpr args

355− jsExpr $

356− if 2 <= arity && arity <= 9 then

357− JS.Call (ref aN) (jsFunc:jsArgs)

358− else

359− foldl1 (<|) (jsFunc:jsArgs)

360

515

361

516

362

517

363−-- GENERATE IFS

518+-- SIMPLIFY INFIX OPERATORS

364

519

365

520

366−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code

521+strictEq :: JS.Expr -> JS.Expr -> JS.Expr

367−generateIf givenBranches givenFinally =

522+strictEq left right =

368− let

523+ case left of

369− (branches, finally) =

524+ JS.Int 0 ->

370− crushIfs givenBranches givenFinally

525+ JS.Prefix JS.PrefixLNot right

371

526

372− convertBranch (condition, expr) =

527+ JS.Bool bool ->

373− (,) <$> generateJsExpr condition <*> generateCode expr

528+ if bool then right else JS.Prefix JS.PrefixLNot right

374

529

375− ifExpression (condition, branch) final =

530+ _ ->

376− JS.If condition branch final

531+ case right of

532+ JS.Int 0 ->

533+ JS.Prefix JS.PrefixLNot left

377

534

378− ifStatement (condition, branch) final =

535+ JS.Bool bool ->

379− JS.IfStmt condition branch final

536+ if bool then left else JS.Prefix JS.PrefixLNot left

380− in

381− do jsBranches <- mapM convertBranch branches

382− jsFinally <- generateCode finally

383

537

384− if any isBlock (jsFinally : map snd jsBranches)

538+ _ ->

385− then

539+ JS.Infix JS.OpStrictEq left right

386− jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]

387− else

388− jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))

389

540

390

541

391−crushIfs

542+strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

392− :: [(Opt.Expr, Opt.Expr)]

543+strictNEq left right =

393− -> Opt.Expr

544+ case left of

394− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

545+ JS.Int 0 ->

395−crushIfs branches finally =

546+ right

396− crushIfsHelp [] branches finally

397

547

548+ JS.Bool bool ->

549+ if bool then JS.Prefix JS.PrefixLNot right else right

398

550

399−crushIfsHelp

551+ _ ->

400− :: [(Opt.Expr, Opt.Expr)]

552+ case right of

401− -> [(Opt.Expr, Opt.Expr)]

553+ JS.Int 0 ->

402− -> Opt.Expr

554+ left

403− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

404−crushIfsHelp visitedBranches unvisitedBranches finally =

405− case unvisitedBranches of

406− [] ->

407− case finally of

408− If subBranches subFinally ->

409− crushIfsHelp visitedBranches subBranches subFinally

410

555

411− _ ->

556+ JS.Bool bool ->

412− (reverse visitedBranches, finally)

557+ if bool then JS.Prefix JS.PrefixLNot left else left

413

558

414− (Literal (L.Boolean True), branch) : _ ->

559+ _ ->

415− crushIfsHelp visitedBranches [] branch

560+ JS.Infix JS.OpStrictNEq left right

416

561

417− visiting : unvisited ->

418− crushIfsHelp (visiting : visitedBranches) unvisited finally

419

562

420

563

564+-- TAIL CALL

421

565

422−-- CASE EXPRESSIONS

423

566

567+-- TODO check if JS minifiers collapse unnecessary temporary variables

568+--

569+generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]

570+generateTailCall mode name args =

571+ let

572+ toTempVars (argName, arg) =

573+ ( Name.makeTemp argName, Just (generateJsExpr mode arg) )

424

574

425−generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]

575+ toRealVars (argName, _) =

426−generateCase exprName decider jumps =

576+ JS.ExprStmt $

427− do labelRoot <- Var.fresh

577+ JS.Assign (JS.LVar (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))

428− jsDecider <- generateDecider exprName labelRoot decider

578+ in

429− foldM (goto labelRoot) jsDecider jumps

579+ JS.Var (map toTempVars args)

580+ : map toRealVars args

581+ ++ [ JS.Continue (Just (Name.fromLocal name)) ]

430

582

431

583

432

584

433−-- handle any jumps

585+-- DEFINITIONS

434

586

435

587

436−goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]

588+generateDef :: Mode -> Opt.Def -> JS.Stmt

437−goto labelRoot deciderStmts (target, branch) =

589+generateDef mode def =

590+ case def of

591+ Opt.Def name body ->

592+ JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]

593+

594+ Opt.TailDef name argNames body ->

438− let

595+ let

439− labeledDeciderStmt =

596+ function =

597+ JS.Function Nothing (map Name.fromLocal argNames)

440− JS.Labelled

598+ [ JS.Labelled (Name.fromLocal name) $

441− (toLabel labelRoot target)

599+ JS.While (JS.Bool True) $

442− (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))

443− in

444− do code <- generateCode branch

600+ codeToStatement $ generateCode mode body

445− return (labeledDeciderStmt : toStatementList code)

601+ ]

602+ in

603+ JS.Var [ (Name.fromLocal name, Just function) ]

446

604

447

605

448−toLabel :: Text -> Int -> JS.Id

449−toLabel root target =

450− JS.Id (root <> "_" <> Text.pack (show target))

451

606

607+-- GENERATE IFS

452

608

453

609

454−-- turn deciders into ifs and switches

610+generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code

611+generateIf mode givenBranches givenFinal =

612+ let

613+ (branches, final) =

614+ crushIfs givenBranches givenFinal

455

615

616+ convertBranch (condition, expr) =

617+ ( generateJsExpr mode condition

618+ , generateCode mode expr

619+ )

456

620

457−generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]

621+ branchExprs = map convertBranch branches

458−generateDecider exprName labelRoot decisionTree =

622+ finalCode = generateCode mode final

459− case decisionTree of

623+ in

460− Opt.Leaf (Opt.Inline branch) ->

624+ if isBlock finalCode || any (isBlock . snd) branchExprs then

461− toStatementList <$> generateCode branch

625+ JsBlock [ foldr addStmtIf (codeToStatement finalCode) branchExprs ]

626+ else

627+ JsExpr $ foldr addExprIf (codeToJsExpr finalCode) branchExprs

462

628

463− Opt.Leaf (Opt.Jump target) ->

464− return [ JS.Break (Just (toLabel labelRoot target)) ]

465

629

466− Opt.Chain testChain success failure ->

630+addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr

467− let

631+addExprIf (condition, branch) final =

468− makeTest (path, test) =

632+ JS.If condition (codeToJsExpr branch) final

469− do testExpr <- pathToTestableExpr exprName path test

470− JS.Infix JS.OpStrictEq testExpr <$> testToExpr test

471− in

472− do testExprs <- mapM makeTest testChain

473− let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs

474− thenBranch <- generateDecider exprName labelRoot success

475− elseBranch <- generateDecider exprName labelRoot failure

476− return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]

477

633

478− Opt.FanOut path edges fallback ->

479− do testExpr <- pathToTestableExpr exprName path (fst (head edges))

480− caseClauses <- mapM (edgeToCase exprName labelRoot) edges

481− caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback

482− return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]

483

634

635+addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt

636+addStmtIf (condition, branch) final =

637+ JS.IfStmt condition (codeToStatement branch) final

484

638

485−edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case

486−edgeToCase exprName labelRoot (test, subTree) =

487− JS.Case

488− <$> testToExpr test

489− <*> generateDecider exprName labelRoot subTree

490

639

640+isBlock :: Code -> Bool

641+isBlock code =

642+ case code of

643+ JsBlock _ -> True

644+ JsExpr _ -> False

491

645

492−testToExpr :: DT.Test -> Generator JS.Expr

493−testToExpr test =

494− case test of

495− DT.Constructor (V.Canonical _ tag) ->

496− return $ JS.String tag

497

646

498− DT.Literal (L.Chr char) ->

647+crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

499− return $ JS.String char

648+crushIfs branches final =

649+ crushIfsHelp [] branches final

500

650

501− DT.Literal lit ->

502− Literal.literal lit

503

651

652+crushIfsHelp

653+ :: [(Opt.Expr, Opt.Expr)]

654+ -> [(Opt.Expr, Opt.Expr)]

655+ -> Opt.Expr

656+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

657+crushIfsHelp visitedBranches unvisitedBranches final =

658+ case unvisitedBranches of

659+ [] ->

660+ case final of

661+ Opt.If subBranches subFinal ->

662+ crushIfsHelp visitedBranches subBranches subFinal

504

663

664+ _ ->

665+ (reverse visitedBranches, final)

505

666

506−-- work with paths

667+ visiting : unvisited ->

668+ crushIfsHelp (visiting : visitedBranches) unvisited final

507

669

508

670

509−pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr

510−pathToTestableExpr root path exampleTest =

511− do accessExpr <- generateJsExpr (pathToExpr root path)

512− case exampleTest of

513− DT.Constructor _ ->

514− return $ JS.DotRef accessExpr (JS.Id "$")

515

671

516− DT.Literal (L.Chr _) ->

672+-- CASE EXPRESSIONS

517− return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []

518

673

519− DT.Literal _ ->

520− return accessExpr

521

674

675+generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]

676+generateCase mode label root decider jumps =

677+ foldr (goto mode label) (generateDecider mode label root decider) jumps

522

678

523−pathToExpr :: Text -> DT.Path -> Opt.Expr

524−pathToExpr root fullPath =

525− go (Opt.VarLocal root) fullPath

526− where

527− go expr path =

528− case path of

529− DT.Position index subpath ->

530− go (Opt.CtorAccess expr index) subpath

531

679

532− DT.Field field subpath ->

680+goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]

533− go (Opt.Access expr field) subpath

681+goto mode label (index, branch) stmts =

682+ let

683+ labeledDeciderStmt =

684+ JS.Labelled

685+ (Name.makeLabel label index)

686+ (JS.While (JS.Bool True) (JS.Block stmts))

687+ in

688+ labeledDeciderStmt : codeToStatementList (generateCode mode branch)

534

689

535− DT.Empty ->

536− expr

537

690

538− DT.Alias ->

691+generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]

539− expr

692+generateDecider mode label root decisionTree =

693+ case decisionTree of

694+ Opt.Leaf (Opt.Inline branch) ->

695+ codeToStatementList (generateCode mode branch)

540

696

697+ Opt.Leaf (Opt.Jump index) ->

698+ [ JS.Break (Just (Name.makeLabel label index)) ]

541

699

700+ Opt.Chain testChain success failure ->

701+ let

702+ makeTest (path, test) =

703+ strictEq

704+ (pathToTestableExpr mode root path test)

705+ (testToExpr mode test)

706+ in

707+ [ JS.IfStmt

708+ (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))

709+ (JS.Block $ generateDecider mode label root success)

710+ (JS.Block $ generateDecider mode label root failure)

711+ ]

542

712

543−-- BINARY OPERATORS

713+ Opt.FanOut path edges fallback ->

714+ [ JS.Switch

715+ (pathToTestableExpr mode root path (fst (head edges)))

716+ ( foldr

717+ (addCase mode label root)

718+ [ JS.Default (generateDecider mode label root fallback) ]

719+ edges

720+ )

721+ ]

544

722

545

723

546−generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code

724+addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]

547−generateBinop op left right =

725+addCase mode label root (test, subTree) cases =

548− do jsLeft <- generateJsExpr left

726+ let stmts = generateDecider mode label root subTree in

549− jsRight <- generateJsExpr right

727+ JS.Case (testToExpr mode test) stmts : cases

550− JsExpr <$> generateBinopHelp op jsLeft jsRight

551

728

552

729

730+testToExpr :: Mode -> DT.Test -> JS.Expr

731+testToExpr mode test =

732+ case test of

733+ DT.IsCtor _ tag index ->

734+ case mode of

735+ Name.Debug ->

736+ JS.String (N.toBuilder tag)

553

737

554−-- BINARY OPERATOR HELPERS

738+ Name.Prod _ ->

739+ JS.Int (Index.toZeroBased index)

555

740

741+ DT.IsInt int ->

742+ JS.Int int

556

743

557−generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr

744+ DT.IsChr char ->

558−generateBinopHelp var@(V.Global home op) jsLeft jsRight =

745+ JS.String (Text.encodeUtf8Builder char)

559− let

560− simpleMake left right =

561− do func <- Var.global var

562− return $ JS.Call (ref "A2") [ func, left, right ]

563− in

564− if home == basics then

565− (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight

566

746

567− else if op == "::" && home == list then

747+ DT.IsStr string ->

568− BuiltIn.cons jsLeft jsRight

748+ JS.String (Text.encodeUtf8Builder string)

569

749

570− else

571− simpleMake jsLeft jsRight

572

750

751+pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr

752+pathToTestableExpr mode root path exampleTest =

753+ let

754+ expr =

755+ pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path

756+ in

757+ case exampleTest of

758+ DT.IsCtor _ _ _ ->

759+ JS.Access expr Name.dollar

573

760

574−list :: ModuleName.Canonical

761+ DT.IsInt _ ->

575−list =

762+ expr

576− ModuleName.inCore "List"

577

763

764+ DT.IsStr _ ->

765+ expr

578

766

579−basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)

767+ DT.IsChr _ ->

580−basicsOps =

768+ case mode of

581− Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)

769+ Name.Debug ->

770+ JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []

582

771

772+ Name.Prod _ ->

773+ expr

583

774

584−basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]

585−basicsOpsNormal =

586− let

587− (=*>) str op =

588− ( str, \left right -> return (JS.Infix op left right) )

589− in

590− [ "+" =*> JS.OpAdd

591− , "-" =*> JS.OpSub

592− , "*" =*> JS.OpMul

593− , "/" =*> JS.OpDiv

594− , "&&" =*> JS.OpLAnd

595− , "||" =*> JS.OpLOr

596− ]

597

775

776+pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr

777+pathToJsExpr mode expr path =

778+ case path of

779+ DT.Index index subpath ->

780+ pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath

598

781

599−basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]

782+ DT.Field field subpath ->

600−basicsOpsSpecial =

783+ pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath

601− let

602− (=*>) = (,)

603− in

604− [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]

605− , "==" =*> BuiltIn.eq

606− , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b

607− , "<" =*> cmp JS.OpLT 0

608− , ">" =*> cmp JS.OpGT 0

609− , "<=" =*> cmp JS.OpLT 1

610− , ">=" =*> cmp JS.OpGT (-1)

611− , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)

612− ]

613

784

785+ DT.Empty ->

786+ expr

614

787

615−cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr

788+ DT.Alias ->

616−cmp op n a b =

789+ expr

617− do ordering <- BuiltIn.cmp a b

618− return $ JS.Infix op ordering (JS.Int n)

src/Generate/JavaScript/Helpers.hsdeleted−98

@@ -1,98 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Generate.JavaScript.Helpers

3− ( varDecl

4− , refOrObject

5− , ref

6− , (==>)

7− , obj

8− , (<|)

9− , function

10− , toFieldName

11− )

12− where

13−

14−

15−import qualified Data.Char as Char

16−import qualified Data.Text as Text

17−import Data.Text (Text)

18−

19−import Generate.JavaScript.Builder

20−

21−

22−

23−-- DECLARATIONS

24−

25−

26−varDecl :: Text -> Expr -> VarDecl

27−varDecl x expr =

28− VarDecl (Id x) (Just expr)

29−

30−

31−refOrObject :: Text -> Expr

32−refOrObject name =

33− Infix OpLOr (ref name) (Object [])

34−

35−

36−

37−-- VARIABLES

38−

39−

40−ref :: Text -> Expr

41−ref name =

42− VarRef (Id name)

43−

44−

45−(==>) :: Text -> Expr -> (Id, Expr)

46−(==>) name expr =

47− ( Id name, expr )

48−

49−

50−obj :: [Text] -> Expr

51−obj vars =

52− case vars of

53− x:xs ->

54− foldl DotRef (ref x) (map Id xs)

55−

56− [] ->

57− error "dotSep must be called on a non-empty list of variables"

58−

59−

60−

61−-- FUNCTION CALLS

62−

63−

64−(<|) :: Expr -> Expr -> Expr

65−(<|) f x =

66− Call f [x]

67−

68−

69−function :: [Text] -> [Stmt] -> Expr

70−function args stmts =

71− Function Nothing (map Id args) stmts

72−

73−

74−

75−-- FIELD NAMES

76−

77−

78−toFieldName :: Int -> Text

79−toFieldName word =

80− Text.pack (toFieldNameHelp word [])

81−

82−

83−toFieldNameHelp :: Int -> [Char] -> [Char]

84−toFieldNameHelp word str =

85− if word < 52 then

86− toChar word : str

87−

88− else

89− let

90− (next, remainder) =

91− quotRem word 52

92− in

93− toFieldNameHelp next (toChar remainder : str)

94−

95−

96−toChar :: Int -> Char

97−toChar word =

98− Char.chr $ fromIntegral $ word + (if word < 26 then 97 else 39)

src/Generate/JavaScript/Literal.hsdeleted−25

@@ -1,25 +0,0 @@

1−module Generate.JavaScript.Literal (literal) where

2−

3−import qualified AST.Literal as Lit

4−import qualified Generate.JavaScript.Builder as JS

5−import qualified Generate.JavaScript.BuiltIn as BuiltIn

6−import Generate.JavaScript.Variable (Generator)

7−

8−

9−literal :: Lit.Literal -> Generator JS.Expr

10−literal lit =

11− case lit of

12− Lit.Chr char ->

13− BuiltIn.char char

14−

15− Lit.Str string ->

16− return $ JS.String string

17−

18− Lit.IntNum number ->

19− return $ JS.Int number

20−

21− Lit.FloatNum number ->

22− return $ JS.Float number

23−

24− Lit.Boolean boolean ->

25− return $ JS.Bool boolean

src/Generate/JavaScript/Variable.hs → src/Generate/JavaScript/Name.hsrenamed+104−81

@@ -1,86 +1,134 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3−module Generate.JavaScript.Variable

3+module Generate.JavaScript.Name

4− ( Generator

4+ ( Name

5− , run

5+ , Mode(..)

6− , fresh

6+ , toBuilder

7− , local

7+ , fromInt

8− , safe

8+ , fromLocal

9− , global

9+ , fromGlobal

10− , globalName

10+ , fromCycle

11− , globalToName

11+ , fromKernel

12− , intToAscii

12+ , fromField

13+ , makeLabel

14+ , makeTemp

15+ , dollar

13 )

16 )

14 where

17 where

17−import qualified Control.Monad.State.Strict as State

20+import qualified Data.ByteString.Builder as B

18−import qualified Data.ByteString as BS

21+import qualified Data.ByteString.Short as S

19import Data.Monoid ((<>))

22import Data.Monoid ((<>))

23+import Data.Map ((!))

20import qualified Data.Map as Map

24import qualified Data.Map as Map

21import qualified Data.Set as Set

25import qualified Data.Set as Set

22−import Data.Text (Text)

23import qualified Data.Text as Text

26import qualified Data.Text as Text

24−import qualified Data.Text.Encoding as Text (encodeUtf8)

27+import qualified Data.Text.Encoding as Text

25import Data.Word (Word8)

28import Data.Word (Word8)

27import qualified AST.Module.Name as ModuleName

30import qualified AST.Module.Name as ModuleName

28−import qualified AST.Variable as Var

31+import qualified Elm.Name as N

29import qualified Elm.Package as Pkg

32import qualified Elm.Package as Pkg

30−import qualified Generate.JavaScript.Builder as JS

31−import qualified Generate.JavaScript.Helpers as JS

35−-- GENERATOR

36+-- NAME

38−type Generator = State.State Int

39+newtype Name =

40+ Name { toBuilder :: B.Builder }

41−run :: Generator a -> a

42−run generator =

43− State.evalState generator 0

44+-- MODE

47−-- FRESH NAMES

47+data Mode

48+ = Debug

49+ | Prod (Map.Map N.Name B.Builder)

50−fresh :: Generator Text

51−fresh =

52− do uid <- State.get

53− State.put (uid + 1)

54− return ("_v" <> Text.pack (show uid))

53+-- CONSTRUCTORS

58−-- LOCAL NAMES

56+fromInt :: Int -> Name

57+fromInt n =

58+ Name (B.shortByteString (intToAscii n))

61−local :: Text -> JS.Expr

61+fromLocal :: N.Name -> Name

62−local name =

62+fromLocal name =

63− JS.ref (safe name)

64−

65−

66−safe :: Text -> Text

67−safe name =

68 if Set.member name reservedNames then

63 if Set.member name reservedNames then

69− "_" <> name

64+ Name ("_" <> N.toBuilder name)

70 else

65 else

71− name

66+ Name (N.toBuilder name)

67+

68+

69+fromGlobal :: ModuleName.Canonical -> N.Name -> Name

70+fromGlobal (ModuleName.Canonical (Pkg.Name user project) home) name =

71+ Name $

72+ Text.encodeUtf8Builder (Text.replace "-" "_" user)

73+ <> "$" <> Text.encodeUtf8Builder (Text.replace "-" "_" project) -- TODO store this in a better way

74+ <> "$" <> N.toBuilder home

75+ <> "$" <> N.toBuilder name

76+

77+

78+fromCycle :: ModuleName.Canonical -> N.Name -> Name

79+fromCycle (ModuleName.Canonical (Pkg.Name user project) home) name =

80+ Name $

81+ Text.encodeUtf8Builder (Text.replace "-" "_" user)

82+ <> "$" <> Text.encodeUtf8Builder (Text.replace "-" "_" project) -- TODO store this in a better way

83+ <> "$" <> N.toBuilder home

84+ <> "$cyclic$" <> N.toBuilder name

85+

86+

87+fromKernel :: N.Name -> N.Name -> Name

88+fromKernel home name =

89+ Name ("_" <> N.toBuilder home <> "_" <> N.toBuilder name)

90+

91+

92+fromField :: Mode -> N.Name -> Name

93+fromField mode name =

94+ case mode of

95+ Debug ->

96+ Name (N.toBuilder name)

97+

98+ Prod fields ->

99+ Name (fields ! name)

100+

101+

102+

103+-- TEMPORARY NAMES

104+

105+

106+makeLabel :: N.Name -> Int -> Name

107+makeLabel name index =

108+ Name (N.toBuilder name <> "$" <> B.intDec index)

109+

110+

111+makeTemp :: N.Name -> Name

112+makeTemp name =

113+ Name ("$temp$" <> N.toBuilder name)

114+

115+

116+dollar :: Name

117+dollar =

118+ Name (N.toBuilder N.dollar)

119

120

121

75-- RESERVED NAMES

122-- RESERVED NAMES

123

124

125+{-# NOINLINE reservedNames #-}

78−reservedNames :: Set.Set Text

126+reservedNames :: Set.Set N.Name

79reservedNames =

127reservedNames =

80 Set.union jsReservedWords elmReservedWords

128 Set.union jsReservedWords elmReservedWords

129

130

83−jsReservedWords :: Set.Set Text

131+jsReservedWords :: Set.Set N.Name

84jsReservedWords =

132jsReservedWords =

85 Set.fromList

133 Set.fromList

86 [ "do", "if", "in"

134 [ "do", "if", "in"

@@ -96,7 +144,7 @@ jsReservedWords =

96 ]

144 ]

145

146

99−elmReservedWords :: Set.Set Text

147+elmReservedWords :: Set.Set N.Name

100elmReservedWords =

148elmReservedWords =

101 Set.fromList

149 Set.fromList

102 [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

150 [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

@@ -105,45 +153,19 @@ elmReservedWords =

105

153

106

154

107

155

108−-- GLOBAL NAMES

109−

110−

111−global :: Var.Global -> Generator JS.Expr

112−global var =

113− JS.ref <$> globalName var

114−

115−

116−globalName :: Var.Global -> Generator Text

117−globalName (Var.Global home name) =

118− return (globalToName home name)

119−

120−

121−globalToName :: ModuleName.Canonical -> Text -> Text

122−globalToName (ModuleName.Canonical (Pkg.Name user project) moduleName) name =

123− if ModuleName.isKernel moduleName then

124− "_" <> ModuleName.getKernel moduleName <> "_" <> name

125−

126− else

127− Text.replace "-" "_" user

128− <> "$" <> Text.replace "-" "_" project

129− <> "$" <> Text.replace "." "_" moduleName

130− <> "$" <> name

131−

132−

133−

134-- INT TO ASCII

156-- INT TO ASCII

135

157

136

158

137−intToAscii :: Int -> BS.ByteString

159+intToAscii :: Int -> S.ShortByteString

138intToAscii n =

160intToAscii n =

139 if n < 53 then -- skip $ as a standalone name

161 if n < 53 then -- skip $ as a standalone name

140− BS.singleton (toByte n)

162+ S.pack [toByte n]

141

163

142 else

164 else

143 intToAsciiHelp (numStartBytes * numInnerBytes) allBadFields (n - 53)

165 intToAsciiHelp (numStartBytes * numInnerBytes) allBadFields (n - 53)

144

166

145

167

146−intToAsciiHelp :: Int -> [BadFields] -> Int -> BS.ByteString

168+intToAsciiHelp :: Int -> [BadFields] -> Int -> S.ShortByteString

147intToAsciiHelp blockSize badFields n =

169intToAsciiHelp blockSize badFields n =

148 case badFields of

170 case badFields of

149 [] ->

171 [] ->

@@ -153,24 +175,25 @@ intToAsciiHelp blockSize badFields n =

153 intToAsciiHelp (blockSize * numInnerBytes) [] (n - blockSize)

175 intToAsciiHelp (blockSize * numInnerBytes) [] (n - blockSize)

154

176

155 BadFields renamings : biggerBadFields ->

177 BadFields renamings : biggerBadFields ->

156− if n < blockSize - Map.size renamings then

178+ let availableSize = blockSize - Map.size renamings in

179+ if n < availableSize then

157 let name = unsafeIntToAscii n in

180 let name = unsafeIntToAscii n in

158 Map.findWithDefault name name renamings

181 Map.findWithDefault name name renamings

159 else

182 else

160− intToAsciiHelp (blockSize * numInnerBytes) biggerBadFields (n - blockSize)

183+ intToAsciiHelp (blockSize * numInnerBytes) biggerBadFields (n - availableSize)

161

184

162

185

163

186

164-- UNSAFE INT TO ASCII

187-- UNSAFE INT TO ASCII

165

188

166

189

167−unsafeIntToAscii :: Int -> BS.ByteString

190+unsafeIntToAscii :: Int -> S.ShortByteString

168unsafeIntToAscii n =

191unsafeIntToAscii n =

169 let

192 let

170 (quotient, remainder) =

193 (quotient, remainder) =

171 quotRem n numStartBytes

194 quotRem n numStartBytes

172 in

195 in

173− BS.pack $ toByte remainder : unsafeIntToAsciiHelp quotient

196+ S.pack $ toByte remainder : unsafeIntToAsciiHelp quotient

174

197

175

198

176unsafeIntToAsciiHelp :: Int -> [Word8]

199unsafeIntToAsciiHelp :: Int -> [Word8]

@@ -215,27 +238,27 @@ newtype BadFields =

215

238

216

239

217type Renamings =

240type Renamings =

218− Map.Map BS.ByteString BS.ByteString

241+ Map.Map S.ShortByteString S.ShortByteString

219

242

220

243

221allBadFields :: [BadFields]

244allBadFields :: [BadFields]

222allBadFields =

245allBadFields =

223 let

246 let

224 add keyword dict =

247 add keyword dict =

225− Map.alter (Just . addRenaming keyword) (Text.length keyword) dict

248+ Map.alter (Just . addRenaming keyword) (N.length keyword) dict

226 in

249 in

227− Map.elems $ Set.foldr add Map.empty jsReservedWords

250+ Map.elems $ Set.foldr add Map.empty jsReservedWords

228

251

229

252

230−addRenaming :: Text -> Maybe BadFields -> BadFields

253+addRenaming :: N.Name -> Maybe BadFields -> BadFields

231addRenaming keyword maybeBadFields =

254addRenaming keyword maybeBadFields =

232 let

255 let

233 maxName =

256 maxName =

234− numStartBytes * numInnerBytes ^ (Text.length keyword - 1) - 1

257+ numStartBytes * numInnerBytes ^ (N.length keyword - 1) - 1

235 in

258 in

236 case maybeBadFields of

259 case maybeBadFields of

237 Nothing ->

260 Nothing ->

238− BadFields $ Map.singleton (Text.encodeUtf8 keyword) (unsafeIntToAscii maxName)

261+ BadFields $ Map.singleton (N.toShort keyword) (unsafeIntToAscii maxName)

239

262

240 Just (BadFields renamings) ->

263 Just (BadFields renamings) ->

241− BadFields $ Map.insert (Text.encodeUtf8 keyword) (unsafeIntToAscii (maxName - Map.size renamings)) renamings

264+ BadFields $ Map.insert (N.toShort keyword) (unsafeIntToAscii (maxName - Map.size renamings)) renamings