git.iko.soy/elk
on master help sign in
Get generation of expressions working again

The code gets a decent bit simpler thanks to the improvements in earlier phases: - There is no more Generator monad. It is just a function from Elm to JS. - Removed Literal, Variable, and Helper modules. Code is clearer without. - The new Name module makes it harder to generate bad names. - Optimization of Bitwise and Basics are combined because infix ops do not exist by this phase. - Added some extra optimizations for things like Tuple.first - Turn (x === 0) into !x which will make ctor tests smaller in prod

commit42c3f755ea728096477cbb819d25f93a7996eea0 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 5 Dec 2017, 14:41 (9 years ago) parentee5f359
7 files changed+818−702
compare with master
unifiedsplit
src/AST/Module/Name.hs+17−7 src/Elm/Name.hs+61−3 src/Generate/JavaScript/Builder.hs+43−66 src/Generate/JavaScript/Expression.hs+593−422 src/Generate/JavaScript/Helpers.hs−98 src/Generate/JavaScript/Literal.hs−25 src/Generate/JavaScript/Variable.hs → src/Generate/JavaScript/Name.hs+104−81
src/AST/Module/Name.hs+17−7
@@ -2,9 +2,10 @@
22{-# LANGUAGE OverloadedStrings #-}
33module AST.Module.Name
44 ( Canonical(..)
5− , basics, char, string, debug
5+ , basics, char, string
66 , maybe, list, array
7− , platform, cmd, sub, virtualDom
7+ , platform, cmd, sub
8+ , virtualDom, debug, bitwise
89 , jsonDecode, jsonEncode
910 , webgl, vector2, vector3, vector4, matrix4
1011 , canonicalToText
@@ -59,11 +60,6 @@ string :: Canonical
5960string = Canonical Pkg.core N.string
6061
6162
62−{-# NOINLINE debug #-}
63−debug :: Canonical
64−debug = Canonical Pkg.core N.debug
65−
66−
6763
6864-- CONTAINERS
6965
@@ -102,11 +98,25 @@ sub :: Canonical
10298sub = Canonical Pkg.core "Platform.Sub"
10399
104100
101+
102+-- MISC
103+
104+
105105{-# NOINLINE virtualDom #-}
106106virtualDom :: Canonical
107107virtualDom = Canonical Pkg.virtualDom "VirtualDom"
108108
109109
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+
110120
111121-- JSON
112122
src/Elm/Name.hs+61−3
@@ -2,20 +2,28 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Elm.Name
44 ( Name
5+ , length
56 , toString
7+ , toBuilder
8+ , toShort
69 , localFromInt
710 , toCompositeName
811 , int, float, bool, char, string
9− , maybe, list, array
12+ , maybe, list, array, tuple
1013 , task, router, cmd, sub
11− , shader, debug, utils, negate, value
14+ , shader, debug, bitwise, basics
15+ , utils, negate, value
16+ , node, program, main, dollar
1217 )
1318 where
1419
1520
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
1724import qualified Data.Set as Set
1825import qualified Data.Text as Text
26+import qualified Data.Text.Encoding as Text
1927
2028
2129
@@ -25,11 +33,26 @@ import qualified Data.Text as Text
2533type Name = Text.Text
2634
2735
36+length :: Name -> Int
37+length =
38+ Text.length
39+
40+
2841toString :: Name -> String
2942toString =
3043 Text.unpack
3144
3245
46+toBuilder :: Name -> B.Builder
47+toBuilder =
48+ Text.encodeUtf8Builder
49+
50+
51+toShort :: Name -> S.ShortByteString
52+toShort =
53+ error "TODO"
54+
55+
3356localFromInt :: Int -> Name
3457localFromInt n =
3558 Text.pack ('x' : show n)
@@ -84,6 +107,11 @@ array :: Name
84107array = "Array"
85108
86109
110+{-# NOINLINE tuple #-}
111+tuple :: Name
112+tuple = "Tuple"
113+
114+
87115{-# NOINLINE task #-}
88116task :: Name
89117task = "Task"
@@ -114,6 +142,16 @@ debug :: Name
114142debug = "Debug"
115143
116144
145+{-# NOINLINE bitwise #-}
146+bitwise :: Name
147+bitwise = "Bitwise"
148+
149+
150+{-# NOINLINE basics #-}
151+basics :: Name
152+basics = "Basics"
153+
154+
117155{-# NOINLINE utils #-}
118156utils :: Name
119157utils = "Utils"
@@ -127,3 +165,23 @@ negate = "negate"
127165{-# NOINLINE value #-}
128166value :: Name
129167value = "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 @@
33module Generate.JavaScript.Builder
44 ( stmtToBuilder
55 , exprToBuilder
6− , Expr(..), Id(..), LValue(..)
7− , Stmt(..), Case(..), VarDecl(..)
6+ , Expr(..), LValue(..)
7+ , Stmt(..), Case(..)
88 , InfixOp(..), PrefixOp(..)
99 )
1010 where
@@ -16,10 +16,10 @@ module Generate.JavaScript.Builder
1616
1717import Prelude hiding (lines)
1818import qualified Data.List as List
19−import Data.ByteString.Builder
19+import Data.ByteString.Builder as B
2020import Data.Monoid ((<>))
21−import Data.Text (Text)
22−import qualified Data.Text.Encoding as Text
21+import qualified Generate.JavaScript.Name as Name
22+import Generate.JavaScript.Name (Name)
2323
2424
2525
@@ -27,30 +27,27 @@ import qualified Data.Text.Encoding as Text
2727
2828
2929data Expr
30− = String Text
30+ = String Builder
3131 | Float Double
3232 | Int Int
3333 | Bool Bool
3434 | Null
3535 | Array [Expr]
36− | Object [(Id, Expr)]
37− | VarRef Id
38− | DotRef Expr Id -- ^ @foo.bar@, spec 11.2.1
39− | BracketRef Expr Expr -- ^ @foo[bar]@, spec 11.2.1
36+ | Object [(Name, Expr)]
37+ | Ref Name
38+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
39+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
4040 | Prefix PrefixOp Expr
4141 | Infix InfixOp Expr Expr
4242 | If Expr Expr Expr
4343 | Assign LValue Expr
4444 | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
45− | Function (Maybe Id) [Id] [Stmt]
46−
47−
48−newtype Id = Id Text
45+ | Function (Maybe Name) [Name] [Stmt]
4946
5047
5148data LValue
52− = LVar Text
53− | LDot Expr Text
49+ = LVar Name
50+ | LDot Expr Name
5451 | LBracket Expr Expr
5552
5653
@@ -63,16 +60,15 @@ data Stmt
6360 | EmptyStmt -- ;
6461 | ExprStmt Expr -- expr;
6562 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
66− | IfSingleStmt Expr Stmt -- if (e) stmt
6763 | Switch Expr [Case] -- switch (e) clauses
6864 | While Expr Stmt -- while (e) do stmt
6965 | DoWhile Stmt Expr -- do stmt while (e);
70− | Break (Maybe Id) -- break lab;
71− | Continue (Maybe Id) -- continue lab;
72− | Labelled Id Stmt -- lab: stmt
66+ | Break (Maybe Name) -- break lab;
67+ | Continue (Maybe Name) -- continue lab;
68+ | Labelled Name Stmt -- lab: stmt
7369 | Return (Maybe Expr) -- return expr;
74− | VarDeclStmt [VarDecl] -- var x, y=42;
75− | FunctionStmt Id [Id] [Stmt] -- function f(x, y, z) {...}
70+ | Var [(Name, Maybe Expr)] -- var x, y=42;
71+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
7672
7773
7874data Case
@@ -80,9 +76,6 @@ data Case
8076 | Default [Stmt]
8177
8278
83−data VarDecl = VarDecl Id (Maybe Expr)
84−
85−
8679
8780-- OPERATORS
8881
@@ -184,13 +177,6 @@ fromStmt indent statement =
184177 , indent, "}\n"
185178 ]
186179
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−
194180 Switch expr clauses ->
195181 mconcat
196182 [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
@@ -216,17 +202,17 @@ fromStmt indent statement =
216202 indent <> "break;\n"
217203
218204 Break (Just label) ->
219− indent <> "break " <> fromId label <> ";\n"
205+ indent <> "break " <> Name.toBuilder label <> ";\n"
220206
221207 Continue Nothing ->
222208 indent <> "continue;\n"
223209
224210 Continue (Just label) ->
225− indent <> "continue " <> fromId label <> ";\n"
211+ indent <> "continue " <> Name.toBuilder label <> ";\n"
226212
227213 Labelled label stmt ->
228214 mconcat
229− [ indent, fromId label, ":\n"
215+ [ indent, Name.toBuilder label, ":\n"
230216 , fromStmt indent stmt
231217 ]
232218
@@ -236,14 +222,14 @@ fromStmt indent statement =
236222 Return (Just expr) ->
237223 indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
238224
239− VarDeclStmt [] ->
225+ Var [] ->
240226 mempty
241227
242− VarDeclStmt decls ->
243− indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"
228+ Var vars ->
229+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
244230
245231 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"
247233 <>
248234 fromStmtBlock (deeper indent) stmts
249235 <>
@@ -267,26 +253,17 @@ fromClause indent clause =
267253
268254
269255
270−-- ID
271−
272−
273−fromId :: Id -> Builder
274−fromId (Id name) =
275− Text.encodeUtf8Builder name
276−
277−
278−
279256-- VAR DECLS
280257
281258
282−fromVarDecl :: Builder -> VarDecl -> Builder
283−fromVarDecl indent (VarDecl (Id name) maybeExpr) =
259+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
260+varToBuilder indent (name, maybeExpr) =
284261 case maybeExpr of
285262 Nothing ->
286− Text.encodeUtf8Builder name
263+ Name.toBuilder name
287264
288265 Just expr ->
289− Text.encodeUtf8Builder name <> " = " <> snd (fromExpr indent Whatever expr)
266+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
290267
291268
292269
@@ -329,13 +306,13 @@ fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
329306fromExpr indent grouping expression =
330307 case expression of
331308 String string ->
332− (One, "'" <> Text.encodeUtf8Builder string <> "'")
309+ (One, "'" <> string <> "'")
333310
334311 Float n ->
335− (One, doubleDec n)
312+ (One, B.doubleDec n)
336313
337314 Int n ->
338− (One, intDec n)
315+ (One, B.intDec n)
339316
340317 Bool bool ->
341318 (One, if bool then "true" else "false")
@@ -376,13 +353,13 @@ fromExpr indent grouping expression =
376353 else
377354 "{" <> commaSep builders <> "}"
378355
379− VarRef name ->
380− (One, fromId name)
356+ Ref name ->
357+ (One, Name.toBuilder name)
381358
382− DotRef expr (Id name) ->
383− makeDot indent expr name
359+ Access expr field ->
360+ makeDot indent expr field
384361
385− BracketRef expr bracketedExpr ->
362+ Index expr bracketedExpr ->
386363 makeBracketed indent expr bracketedExpr
387364
388365 Prefix op expr ->
@@ -448,7 +425,7 @@ fromExpr indent grouping expression =
448425
449426 Function maybeName args stmts ->
450427 (,) 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"
452429 <>
453430 fromStmtBlock (deeper indent) stmts
454431 <>
@@ -459,14 +436,14 @@ fromExpr indent grouping expression =
459436-- FIELDS
460437
461438
462−fromField :: Builder -> (Id, Expr) -> (Lines, Builder)
439+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
463440fromField indent (field, expr) =
464441 let
465442 (lines, builder) =
466443 fromExpr indent Whatever expr
467444 in
468445 ( lines
469− , fromId field <> ": " <> builder
446+ , Name.toBuilder field <> ": " <> builder
470447 )
471448
472449
@@ -478,7 +455,7 @@ fromLValue :: Builder -> LValue -> (Lines, Builder)
478455fromLValue indent lValue =
479456 case lValue of
480457 LVar name ->
481− (One, Text.encodeUtf8Builder name)
458+ (One, Name.toBuilder name)
482459
483460 LDot expr field ->
484461 makeDot indent expr field
@@ -487,13 +464,13 @@ fromLValue indent lValue =
487464 makeBracketed indent expr bracketedExpr
488465
489466
490−makeDot :: Builder -> Expr -> Text -> (Lines, Builder)
467+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
491468makeDot indent expr field =
492469 let
493470 (lines, builder) =
494471 fromExpr indent Atomic expr
495472 in
496− (lines, builder <> "." <> Text.encodeUtf8Builder field)
473+ (lines, builder <> "." <> Name.toBuilder field)
497474
498475
499476makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
src/Generate/JavaScript/Expression.hs+593−422
@@ -1,70 +1,171 @@
11{-# LANGUAGE OverloadedStrings #-}
22module Generate.JavaScript.Expression
3− ( generateDecl
3+ ( generateJsExpr
44 )
55 where
66
7−import Prelude hiding (exp)
8−import Control.Arrow (second)
9−import Control.Monad (foldM)
7+
8+import qualified Data.IntMap as IntMap
109import qualified Data.List as List
1110import qualified Data.Map as Map
12−import Data.Monoid ((<>))
13−import qualified Data.Text as Text
14−import Data.Text (Text)
11+import qualified Data.Text.Encoding as Text
1512
16−import AST.Expression.Optimized as Opt
17−import qualified AST.Literal as L
13+import qualified AST.Optimized as Opt
1814import qualified AST.Module.Name as ModuleName
19−import qualified AST.Variable as V
20−import Generate.JavaScript.Helpers as Help
15+import qualified Data.Index as Index
16+import qualified Elm.Name as N
17+import qualified Elm.Package as Pkg
2118import qualified Generate.JavaScript.Builder as JS
22−import qualified Generate.JavaScript.BuiltIn as BuiltIn
23−import qualified Generate.JavaScript.Literal as Literal
24−import qualified Generate.JavaScript.Variable as Var
25−import Generate.JavaScript.Variable (Generator)
19+import qualified Generate.JavaScript.Name as Name
2620import qualified Optimize.DecisionTree as DT
21+import qualified Reporting.Region as R
2722
2823
2924
30−-- GENERATE DECLARATION
25+-- ENVIRONMENT
3126
3227
33−generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt
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 ]
28+type Mode = Name.Mode
3829
3930
4031
41−-- CODE CHUNKS
32+-- EXPRESSIONS
4233
4334
44−data Code
45− = JsExpr JS.Expr
46− | JsBlock [JS.Stmt]
35+generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
36+generateJsExpr mode expression =
37+ codeToJsExpr (generateCode mode expression)
4738
4839
49−jsExpr :: JS.Expr -> Generator Code
50−jsExpr exp =
51− return (JsExpr exp)
40+generateCode :: Mode -> Opt.Expr -> Code
41+generateCode mode expression =
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) ]
5248
49+ Name.Prod _ ->
50+ JS.String (Text.encodeUtf8Builder char)
5351
54−jsBlock :: [JS.Stmt] -> Generator Code
55−jsBlock stmts =
56− return (JsBlock stmts)
52+ Opt.Str string ->
53+ JsExpr $ JS.String (Text.encodeUtf8Builder string)
5754
55+ Opt.Int int ->
56+ JsExpr $ JS.Int int
5857
59−isBlock :: Code -> Bool
60−isBlock code =
58+ Opt.Float float ->
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 =
61159 case code of
62− JsBlock _ -> True
63− JsExpr _ -> False
160+ JsExpr expr ->
161+ expr
162+
163+ JsBlock stmts ->
164+ JS.Call (JS.Function Nothing [] stmts) []
64165
65166
66−toStatementList :: Code -> [JS.Stmt]
67−toStatementList code =
167+codeToStatementList :: Code -> [JS.Stmt]
168+codeToStatementList code =
68169 case code of
69170 JsExpr expr ->
70171 [ JS.Return (Just expr) ]
@@ -73,8 +174,8 @@ toStatementList code =
73174 stmts
74175
75176
76−toStatement :: Code -> JS.Stmt
77−toStatement code =
177+codeToStatement :: Code -> JS.Stmt
178+codeToStatement code =
78179 case code of
79180 JsExpr expr ->
80181 JS.Return (Just expr)
@@ -86,533 +187,603 @@ toStatement code =
86187 JS.Block stmts
87188
88189
89−toExpr :: Code -> JS.Expr
90−toExpr code =
91− case code of
92− JsExpr expr ->
93− expr
94190
95− JsBlock stmts ->
96− JS.Call (function [] stmts) []
191+-- CHARS
97192
98193
99−
100−-- EXPRESSIONS
194+{-# NOINLINE toChar #-}
195+toChar :: JS.Expr
196+toChar =
197+ JS.Ref (Name.fromKernel N.utils "chr")
101198
102199
103−generateJsExpr :: Opt.Expr -> Generator JS.Expr
104−generateJsExpr optExpr =
105− toExpr <$> generateCode optExpr
106200
201+-- RECORDS
107202
108−generateCode :: Opt.Expr -> Generator Code
109−generateCode expr =
110− case expr of
111− VarLocal name ->
112− jsExpr $ Var.local name
113203
114− VarGlobal name ->
115− JsExpr <$> Var.global name
204+generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr
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))
116211
117− Literal lit ->
118− JsExpr <$> Literal.literal lit
119212
120− Access record field ->
121− do jsRecord <- generateJsExpr record
122− jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
123213
124− Update record fields ->
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
214+-- DEBUG
133215
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
142216
143− Binop op leftExpr rightExpr ->
144− generateBinop op leftExpr rightExpr
217+generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr
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+ ]
145228
146− Function args body ->
147− generateFunction args body
229+ Just valueName ->
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+ ]
148235
149− Call func args ->
150− generateCall func args
151236
152− TailCall name argNames args ->
153− let
154− reassign argName tempName =
155− JS.ExprStmt $
156− JS.Assign (JS.LVar (Var.safe argName)) (ref tempName)
157− in
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)))]
237+regionToJsExpr :: R.Region -> JS.Expr
238+regionToJsExpr (R.Region start end) =
239+ JS.Object
240+ [ ( Name.fromLocal "start", positionToJsExpr start )
241+ , ( Name.fromLocal "end", positionToJsExpr end )
242+ ]
164243
165− Let defs body ->
166− do stmts <- mapM generateLetDef defs
167− code <- generateCode body
168− jsBlock (stmts ++ toStatementList code)
169244
170− If branches finally ->
171− generateIf branches finally
245+positionToJsExpr :: R.Position -> JS.Expr
246+positionToJsExpr (R.Position line column) =
247+ JS.Object
248+ [ ( Name.fromLocal "line", JS.Int line )
249+ , ( Name.fromLocal "column", JS.Int column )
250+ ]
172251
173− Case exprName decider jumps ->
174− JsBlock <$> generateCase exprName decider jumps
175252
176− List elements ->
177− do jsElements <- mapM generateJsExpr elements
178− JsExpr <$> BuiltIn.list jsElements
179253
180− Ctor tag members ->
181− let
182− tagField =
183− "$" ==> JS.String tag
254+-- FUNCTION
184255
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 .. ])
190256
191− CtorAccess dataExpr index ->
192− do jsDataExpr <- generateJsExpr dataExpr
193− jsExpr $ JS.DotRef jsDataExpr (JS.Id (Help.toFieldName index))
257+generateFunction :: [N.Name] -> Code -> Code
258+generateFunction args body =
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+ ]
194289
195− Cmd moduleName _ ->
196− JsExpr <$> BuiltIn.effect moduleName
197290
198− Sub moduleName _ ->
199− JsExpr <$> BuiltIn.effect moduleName
200291
201− OutgoingPort name encoder ->
202− do jsEncoder <- generateJsExpr encoder
203− JsExpr <$> BuiltIn.outgoingPort name jsEncoder
292+-- CALLS
204293
205− IncomingPort name decoder ->
206− do jsDecoder <- generateJsExpr decoder
207− JsExpr <$> BuiltIn.incomingPort name jsDecoder
208294
209− Program kind body ->
210− generateProgram kind body
295+generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
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
211300
212− GLShader src ->
213− do string <- Literal.literal (L.Str src)
214− jsExpr $ JS.Object [(JS.StringProp "src", string)]
301+ _ ->
302+ generateNormalCall
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+ ]
215335
216− Crash home region maybeBranchProblem ->
217− do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
218− JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem
219336
220337
338+-- CORE CALLS
221339
222−-- PROGRAMS
223340
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
224345
225−generateProgram :: Opt.Main -> Opt.Expr -> Generator Code
226−generateProgram kind body =
227− case kind of
228− Opt.Static ->
229− do html <- generateJsExpr body
230− func <- BuiltIn.staticProgram
231− jsExpr (func <| html)
346+ else if moduleName == N.bitwise then
347+ generateBitwiseCall home name (map (generateJsExpr mode) args)
232348
233− Opt.Dynamic decoder ->
234− do almostProgram <- generateJsExpr body
235− flagDecoder <- generateJsExpr decoder
236− jsExpr (almostProgram <| flagDecoder)
349+ else if moduleName == N.tuple then
350+ generateTupleCall home name (map (generateJsExpr mode) args)
237351
352+ else
353+ generateNormalCall' home name (map (generateJsExpr mode) args)
238354
239355
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
241364
365+ _ ->
366+ generateNormalCall' home name args
242367
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 ]
247368
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
248376
249−generateDef :: Text -> Opt.Def -> Generator JS.Expr
250−generateDef name def =
251− case def of
252− Opt.TailDef argNames body ->
253− generateTailFunction name argNames body
377+ [left,right] ->
378+ case name of
379+ "and" -> JS.Infix JS.OpBAnd left right
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
254386
255− Opt.Def body ->
256− generateJsExpr body
387+ _ ->
388+ generateNormalCall' home name args
257389
258390
259−generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
260−generateTailFunction name args body =
261− do code <- generateCode body
262− return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
263− JS.Labelled
264− (JS.Id (Var.safe name))
265− (JS.While (JS.Bool True) (toStatement code))
391+generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr
392+generateBasicsCall mode home name args =
393+ case args of
394+ [elmArg] ->
395+ let arg = generateJsExpr mode elmArg in
396+ case name of
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]
266401
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]
267429
430+ _ ->
431+ generateNormalCall' home name (map (generateJsExpr mode) args)
268432
269−-- FUNCTIONS
270433
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]
271440
272−generateFunction :: [Text] -> Opt.Expr -> Generator Code
273−generateFunction args body =
274− do code <- generateCode body
275− jsExpr (generateFunctionWithArity args code)
276441
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]
277449
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
295450
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)
296459
297460
298−-- GENERATE CALL
461+isLiteral :: JS.Expr -> Bool
462+isLiteral expr =
463+ case expr of
464+ JS.String _ ->
465+ True
299466
467+ JS.Float _ ->
468+ True
300469
301−generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
302−generateCall func args =
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
470+ JS.Int _ ->
471+ True
309472
310− (Opt.VarGlobal (V.Global home name), [ left, right ]) | home == bitwise ->
311− case name of
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
473+ JS.Bool _ ->
474+ True
319475
320476 _ ->
321− generateCallHelp func args
477+ False
322478
323479
324−genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
325−genPrefix op arg =
326− do jsArg <- generateJsExpr arg
327− jsExpr (JS.Prefix op jsArg)
480+decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr
481+decomposeL mode expr funcs =
482+ case expr of
483+ Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]
484+ | home == ModuleName.basics ->
485+ decomposeL mode left (func:funcs)
328486
487+ _ ->
488+ generateJsExpr mode $
489+ Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
329490
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
335491
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
336498
337−basics :: ModuleName.Canonical
338−basics =
339− ModuleName.inCore "Basics"
499+ _ ->
500+ generateJsExpr mode $
501+ Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))
340502
341503
342−bitwise :: ModuleName.Canonical
343−bitwise =
344− ModuleName.inCore "Bitwise"
504+apply :: Opt.Expr -> Opt.Expr -> Opt.Expr
505+apply func value =
506+ case func of
507+ Opt.Accessor field ->
508+ Opt.Access value field
345509
510+ Opt.Call f args ->
511+ Opt.Call f (args ++ [value])
346512
347−generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
348−generateCallHelp func args =
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)
513+ _ ->
514+ Opt.Call func [value]
360515
361516
362517
363−-- GENERATE IFS
518+-- SIMPLIFY INFIX OPERATORS
364519
365520
366−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
367−generateIf givenBranches givenFinally =
368− let
369− (branches, finally) =
370− crushIfs givenBranches givenFinally
521+strictEq :: JS.Expr -> JS.Expr -> JS.Expr
522+strictEq left right =
523+ case left of
524+ JS.Int 0 ->
525+ JS.Prefix JS.PrefixLNot right
371526
372− convertBranch (condition, expr) =
373− (,) <$> generateJsExpr condition <*> generateCode expr
527+ JS.Bool bool ->
528+ if bool then right else JS.Prefix JS.PrefixLNot right
374529
375− ifExpression (condition, branch) final =
376− JS.If condition branch final
530+ _ ->
531+ case right of
532+ JS.Int 0 ->
533+ JS.Prefix JS.PrefixLNot left
377534
378− ifStatement (condition, branch) final =
379− JS.IfStmt condition branch final
380− in
381− do jsBranches <- mapM convertBranch branches
382− jsFinally <- generateCode finally
535+ JS.Bool bool ->
536+ if bool then left else JS.Prefix JS.PrefixLNot left
383537
384− if any isBlock (jsFinally : map snd jsBranches)
385− then
386− jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
387− else
388− jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
538+ _ ->
539+ JS.Infix JS.OpStrictEq left right
389540
390541
391−crushIfs
392− :: [(Opt.Expr, Opt.Expr)]
393− -> Opt.Expr
394− -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
395−crushIfs branches finally =
396− crushIfsHelp [] branches finally
542+strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
543+strictNEq left right =
544+ case left of
545+ JS.Int 0 ->
546+ right
397547
548+ JS.Bool bool ->
549+ if bool then JS.Prefix JS.PrefixLNot right else right
398550
399−crushIfsHelp
400− :: [(Opt.Expr, Opt.Expr)]
401− -> [(Opt.Expr, Opt.Expr)]
402− -> Opt.Expr
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
551+ _ ->
552+ case right of
553+ JS.Int 0 ->
554+ left
410555
411− _ ->
412− (reverse visitedBranches, finally)
556+ JS.Bool bool ->
557+ if bool then JS.Prefix JS.PrefixLNot left else left
413558
414− (Literal (L.Boolean True), branch) : _ ->
415− crushIfsHelp visitedBranches [] branch
559+ _ ->
560+ JS.Infix JS.OpStrictNEq left right
416561
417− visiting : unvisited ->
418− crushIfsHelp (visiting : visitedBranches) unvisited finally
419562
420563
564+-- TAIL CALL
421565
422−-- CASE EXPRESSIONS
423566
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) )
424574
425−generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
426−generateCase exprName decider jumps =
427− do labelRoot <- Var.fresh
428− jsDecider <- generateDecider exprName labelRoot decider
429− foldM (goto labelRoot) jsDecider jumps
575+ toRealVars (argName, _) =
576+ JS.ExprStmt $
577+ JS.Assign (JS.LVar (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
578+ in
579+ JS.Var (map toTempVars args)
580+ : map toRealVars args
581+ ++ [ JS.Continue (Just (Name.fromLocal name)) ]
430582
431583
432584
433−-- handle any jumps
585+-- DEFINITIONS
434586
435587
436−goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
437−goto labelRoot deciderStmts (target, branch) =
438− let
439− labeledDeciderStmt =
440− JS.Labelled
441− (toLabel labelRoot target)
442− (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
443− in
444− do code <- generateCode branch
445− return (labeledDeciderStmt : toStatementList code)
588+generateDef :: Mode -> Opt.Def -> JS.Stmt
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 ->
595+ let
596+ function =
597+ JS.Function Nothing (map Name.fromLocal argNames)
598+ [ JS.Labelled (Name.fromLocal name) $
599+ JS.While (JS.Bool True) $
600+ codeToStatement $ generateCode mode body
601+ ]
602+ in
603+ JS.Var [ (Name.fromLocal name, Just function) ]
446604
447605
448−toLabel :: Text -> Int -> JS.Id
449−toLabel root target =
450− JS.Id (root <> "_" <> Text.pack (show target))
451606
607+-- GENERATE IFS
452608
453609
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
455615
616+ convertBranch (condition, expr) =
617+ ( generateJsExpr mode condition
618+ , generateCode mode expr
619+ )
456620
457−generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
458−generateDecider exprName labelRoot decisionTree =
459− case decisionTree of
460− Opt.Leaf (Opt.Inline branch) ->
461− toStatementList <$> generateCode branch
621+ branchExprs = map convertBranch branches
622+ finalCode = generateCode mode final
623+ in
624+ if isBlock finalCode || any (isBlock . snd) branchExprs then
625+ JsBlock [ foldr addStmtIf (codeToStatement finalCode) branchExprs ]
626+ else
627+ JsExpr $ foldr addExprIf (codeToJsExpr finalCode) branchExprs
462628
463− Opt.Leaf (Opt.Jump target) ->
464− return [ JS.Break (Just (toLabel labelRoot target)) ]
465629
466− Opt.Chain testChain success failure ->
467− let
468− makeTest (path, test) =
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) ]
630+addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
631+addExprIf (condition, branch) final =
632+ JS.If condition (codeToJsExpr branch) final
477633
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]) ]
483634
635+addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
636+addStmtIf (condition, branch) final =
637+ JS.IfStmt condition (codeToStatement branch) final
484638
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
490639
640+isBlock :: Code -> Bool
641+isBlock code =
642+ case code of
643+ JsBlock _ -> True
644+ JsExpr _ -> False
491645
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
497646
498− DT.Literal (L.Chr char) ->
499− return $ JS.String char
647+crushIfs :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
648+crushIfs branches final =
649+ crushIfsHelp [] branches final
500650
501− DT.Literal lit ->
502− Literal.literal lit
503651
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
504663
664+ _ ->
665+ (reverse visitedBranches, final)
505666
506−-- work with paths
667+ visiting : unvisited ->
668+ crushIfsHelp (visiting : visitedBranches) unvisited final
507669
508670
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 "$")
515671
516− DT.Literal (L.Chr _) ->
517− return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
672+-- CASE EXPRESSIONS
518673
519− DT.Literal _ ->
520− return accessExpr
521674
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
522678
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
531679
532− DT.Field field subpath ->
533− go (Opt.Access expr field) subpath
680+goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]
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)
534689
535− DT.Empty ->
536− expr
537690
538− DT.Alias ->
539− expr
691+generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
692+generateDecider mode label root decisionTree =
693+ case decisionTree of
694+ Opt.Leaf (Opt.Inline branch) ->
695+ codeToStatementList (generateCode mode branch)
540696
697+ Opt.Leaf (Opt.Jump index) ->
698+ [ JS.Break (Just (Name.makeLabel label index)) ]
541699
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+ ]
542712
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+ ]
544722
545723
546−generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
547−generateBinop op left right =
548− do jsLeft <- generateJsExpr left
549− jsRight <- generateJsExpr right
550− JsExpr <$> generateBinopHelp op jsLeft jsRight
724+addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]
725+addCase mode label root (test, subTree) cases =
726+ let stmts = generateDecider mode label root subTree in
727+ JS.Case (testToExpr mode test) stmts : cases
551728
552729
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)
553737
554−-- BINARY OPERATOR HELPERS
738+ Name.Prod _ ->
739+ JS.Int (Index.toZeroBased index)
555740
741+ DT.IsInt int ->
742+ JS.Int int
556743
557−generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
558−generateBinopHelp var@(V.Global home op) jsLeft jsRight =
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
744+ DT.IsChr char ->
745+ JS.String (Text.encodeUtf8Builder char)
566746
567− else if op == "::" && home == list then
568− BuiltIn.cons jsLeft jsRight
747+ DT.IsStr string ->
748+ JS.String (Text.encodeUtf8Builder string)
569749
570− else
571− simpleMake jsLeft jsRight
572750
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
573760
574−list :: ModuleName.Canonical
575−list =
576− ModuleName.inCore "List"
761+ DT.IsInt _ ->
762+ expr
577763
764+ DT.IsStr _ ->
765+ expr
578766
579−basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
580−basicsOps =
581− Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
767+ DT.IsChr _ ->
768+ case mode of
769+ Name.Debug ->
770+ JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
582771
772+ Name.Prod _ ->
773+ expr
583774
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− ]
597775
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
598781
599−basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
600−basicsOpsSpecial =
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− ]
782+ DT.Field field subpath ->
783+ pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath
613784
785+ DT.Empty ->
786+ expr
614787
615−cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
616−cmp op n a b =
617− do ordering <- BuiltIn.cmp a b
618− return $ JS.Infix op ordering (JS.Int n)
788+ DT.Alias ->
789+ expr
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 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Generate.JavaScript.Variable
4− ( Generator
5− , run
6− , fresh
7− , local
8− , safe
9− , global
10− , globalName
11− , globalToName
12− , intToAscii
3+module Generate.JavaScript.Name
4+ ( Name
5+ , Mode(..)
6+ , toBuilder
7+ , fromInt
8+ , fromLocal
9+ , fromGlobal
10+ , fromCycle
11+ , fromKernel
12+ , fromField
13+ , makeLabel
14+ , makeTemp
15+ , dollar
1316 )
1417 where
1518
1619
17−import qualified Control.Monad.State.Strict as State
18−import qualified Data.ByteString as BS
20+import qualified Data.ByteString.Builder as B
21+import qualified Data.ByteString.Short as S
1922import Data.Monoid ((<>))
23+import Data.Map ((!))
2024import qualified Data.Map as Map
2125import qualified Data.Set as Set
22−import Data.Text (Text)
2326import qualified Data.Text as Text
24−import qualified Data.Text.Encoding as Text (encodeUtf8)
27+import qualified Data.Text.Encoding as Text
2528import Data.Word (Word8)
2629
2730import qualified AST.Module.Name as ModuleName
28−import qualified AST.Variable as Var
31+import qualified Elm.Name as N
2932import qualified Elm.Package as Pkg
30−import qualified Generate.JavaScript.Builder as JS
31−import qualified Generate.JavaScript.Helpers as JS
3233
3334
3435
35−-- GENERATOR
36+-- NAME
3637
3738
38−type Generator = State.State Int
39+newtype Name =
40+ Name { toBuilder :: B.Builder }
3941
4042
41−run :: Generator a -> a
42−run generator =
43− State.evalState generator 0
4443
44+-- MODE
4545
4646
47−-- FRESH NAMES
47+data Mode
48+ = Debug
49+ | Prod (Map.Map N.Name B.Builder)
4850
4951
50−fresh :: Generator Text
51−fresh =
52− do uid <- State.get
53− State.put (uid + 1)
54− return ("_v" <> Text.pack (show uid))
5552
53+-- CONSTRUCTORS
5654
5755
58−-- LOCAL NAMES
56+fromInt :: Int -> Name
57+fromInt n =
58+ Name (B.shortByteString (intToAscii n))
5959
6060
61−local :: Text -> JS.Expr
62−local name =
63− JS.ref (safe name)
64−
65−
66−safe :: Text -> Text
67−safe name =
61+fromLocal :: N.Name -> Name
62+fromLocal name =
6863 if Set.member name reservedNames then
69− "_" <> name
64+ Name ("_" <> N.toBuilder name)
7065 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)
72119
73120
74121
75122-- RESERVED NAMES
76123
77124
78−reservedNames :: Set.Set Text
125+{-# NOINLINE reservedNames #-}
126+reservedNames :: Set.Set N.Name
79127reservedNames =
80128 Set.union jsReservedWords elmReservedWords
81129
82130
83−jsReservedWords :: Set.Set Text
131+jsReservedWords :: Set.Set N.Name
84132jsReservedWords =
85133 Set.fromList
86134 [ "do", "if", "in"
@@ -96,7 +144,7 @@ jsReservedWords =
96144 ]
97145
98146
99−elmReservedWords :: Set.Set Text
147+elmReservedWords :: Set.Set N.Name
100148elmReservedWords =
101149 Set.fromList
102150 [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
@@ -105,45 +153,19 @@ elmReservedWords =
105153
106154
107155
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−
134156-- INT TO ASCII
135157
136158
137−intToAscii :: Int -> BS.ByteString
159+intToAscii :: Int -> S.ShortByteString
138160intToAscii n =
139161 if n < 53 then -- skip $ as a standalone name
140− BS.singleton (toByte n)
162+ S.pack [toByte n]
141163
142164 else
143165 intToAsciiHelp (numStartBytes * numInnerBytes) allBadFields (n - 53)
144166
145167
146−intToAsciiHelp :: Int -> [BadFields] -> Int -> BS.ByteString
168+intToAsciiHelp :: Int -> [BadFields] -> Int -> S.ShortByteString
147169intToAsciiHelp blockSize badFields n =
148170 case badFields of
149171 [] ->
@@ -153,24 +175,25 @@ intToAsciiHelp blockSize badFields n =
153175 intToAsciiHelp (blockSize * numInnerBytes) [] (n - blockSize)
154176
155177 BadFields renamings : biggerBadFields ->
156− if n < blockSize - Map.size renamings then
178+ let availableSize = blockSize - Map.size renamings in
179+ if n < availableSize then
157180 let name = unsafeIntToAscii n in
158181 Map.findWithDefault name name renamings
159182 else
160− intToAsciiHelp (blockSize * numInnerBytes) biggerBadFields (n - blockSize)
183+ intToAsciiHelp (blockSize * numInnerBytes) biggerBadFields (n - availableSize)
161184
162185
163186
164187-- UNSAFE INT TO ASCII
165188
166189
167−unsafeIntToAscii :: Int -> BS.ByteString
190+unsafeIntToAscii :: Int -> S.ShortByteString
168191unsafeIntToAscii n =
169192 let
170193 (quotient, remainder) =
171194 quotRem n numStartBytes
172195 in
173− BS.pack $ toByte remainder : unsafeIntToAsciiHelp quotient
196+ S.pack $ toByte remainder : unsafeIntToAsciiHelp quotient
174197
175198
176199unsafeIntToAsciiHelp :: Int -> [Word8]
@@ -215,27 +238,27 @@ newtype BadFields =
215238
216239
217240type Renamings =
218− Map.Map BS.ByteString BS.ByteString
241+ Map.Map S.ShortByteString S.ShortByteString
219242
220243
221244allBadFields :: [BadFields]
222245allBadFields =
223246 let
224247 add keyword dict =
225− Map.alter (Just . addRenaming keyword) (Text.length keyword) dict
248+ Map.alter (Just . addRenaming keyword) (N.length keyword) dict
226249 in
227− Map.elems $ Set.foldr add Map.empty jsReservedWords
250+ Map.elems $ Set.foldr add Map.empty jsReservedWords
228251
229252
230−addRenaming :: Text -> Maybe BadFields -> BadFields
253+addRenaming :: N.Name -> Maybe BadFields -> BadFields
231254addRenaming keyword maybeBadFields =
232255 let
233256 maxName =
234− numStartBytes * numInnerBytes ^ (Text.length keyword - 1) - 1
257+ numStartBytes * numInnerBytes ^ (N.length keyword - 1) - 1
235258 in
236259 case maybeBadFields of
237260 Nothing ->
238− BadFields $ Map.singleton (Text.encodeUtf8 keyword) (unsafeIntToAscii maxName)
261+ BadFields $ Map.singleton (N.toShort keyword) (unsafeIntToAscii maxName)
239262
240263 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