git.iko.soy/elk
on master help sign in
Get rid of dependency on language-ecmascript
e07d16bEvan Czaplicki
elm-compiler.cabal−2
compare with master
unifiedsplit
@@ -149,7 +149,6 @@ Library
149 directory >= 1.0 && < 2.0,
149 directory >= 1.0 && < 2.0,
150 edit-distance >= 0.2 && < 0.3,
150 edit-distance >= 0.2 && < 0.3,
151 filepath >= 1 && < 2.0,
151 filepath >= 1 && < 2.0,
152− language-ecmascript >= 0.15 && < 0.18,
153 language-glsl >= 0.0.2 && < 0.3,
152 language-glsl >= 0.0.2 && < 0.3,
154 mtl >= 2.2 && < 3,
153 mtl >= 2.2 && < 3,
155 pretty >= 1.0 && < 2.0,
154 pretty >= 1.0 && < 2.0,
@@ -220,7 +219,6 @@ Test-Suite compiler-tests
220 edit-distance >= 0.2 && < 0.3,
219 edit-distance >= 0.2 && < 0.3,
221 filemanip >= 0.3.5 && < 0.4,
220 filemanip >= 0.3.5 && < 0.4,
222 filepath >= 1 && < 2.0,
221 filepath >= 1 && < 2.0,
223− language-ecmascript >= 0.15 && < 0.18,
224 language-glsl >= 0.0.2 && < 0.3,
222 language-glsl >= 0.0.2 && < 0.3,
225 mtl >= 2.2 && < 3,
223 mtl >= 2.2 && < 3,
226 pretty >= 1.0 && < 2.0,
224 pretty >= 1.0 && < 2.0,
src/Generate/JavaScript.hs+16−14
@@ -1,14 +1,16 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
1module Generate.JavaScript (generate) where
3module Generate.JavaScript (generate) where
2
4
3import qualified Control.Monad.State as State
5import qualified Control.Monad.State as State
6+import Data.Text (Text)
4import qualified Data.Text.Lazy as LazyText
7import qualified Data.Text.Lazy as LazyText
5−import qualified Language.ECMAScript3.Syntax as JS
6
8
7import qualified AST.Effects as Effects
9import qualified AST.Effects as Effects
8import qualified AST.Module as Module
10import qualified AST.Module as Module
9import qualified AST.Module.Name as ModuleName
11import qualified AST.Module.Name as ModuleName
10import qualified Elm.Package as Pkg
12import qualified Elm.Package as Pkg
11−import qualified Generate.JavaScript.Builder as Builder
13+import qualified Generate.JavaScript.Builder as JS
12import qualified Generate.JavaScript.Expression as JS
14import qualified Generate.JavaScript.Expression as JS
13import qualified Generate.JavaScript.Helpers as JS
15import qualified Generate.JavaScript.Helpers as JS
14import qualified Generate.JavaScript.Variable as Var
16import qualified Generate.JavaScript.Variable as Var
@@ -29,14 +31,14 @@ generate (Module.Module moduleName _ info) =
29 body =
31 body =
30 State.evalState genBody 0
32 State.evalState genBody 0
31 in
33 in
32− Builder.stmtsToText body
34+ JS.stmtsToText body
33
35
34
36
35
37
36-- GENERATE EFFECT MANAGER
38-- GENERATE EFFECT MANAGER
37
39
38
40
39−generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Statement ()]
41+generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Stmt]
40generateEffectManager moduleName effects =
42generateEffectManager moduleName effects =
41 case effects of
43 case effects of
42 Effects.None ->
44 Effects.None ->
@@ -51,15 +53,15 @@ generateEffectManager moduleName effects =
51 Var.coreNative "Platform" "effectManagers"
53 Var.coreNative "Platform" "effectManagers"
52
54
53 managerName =
55 managerName =
54− JS.StringLit () (ModuleName.canonicalToString moduleName)
56+ JS.String (ModuleName.canonicalToText moduleName)
55
57
56 entry name =
58 entry name =
57− ( JS.PropId () (JS.Id () name)
59+ ( JS.IdProp (JS.Id name)
58 , JS.ref (Var.qualified moduleName name)
60 , JS.ref (Var.qualified moduleName name)
59 )
61 )
60
62
61 managerEntries =
63 managerEntries =
62− [ "pkg" ==> Pkg.toString pkgName
64+ [ "pkg" ==> Pkg.toText pkgName
63 , entry "init"
65 , entry "init"
64 , entry "onEffects"
66 , entry "onEffects"
65 , entry "onSelfMsg"
67 , entry "onSelfMsg"
@@ -77,15 +79,15 @@ generateEffectManager moduleName effects =
77 [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
79 [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
78
80
79 addManager =
81 addManager =
80− JS.AssignExpr () JS.OpAssign
82+ JS.Assign JS.OpAssign
81− (JS.LBracket () managers managerName)
83+ (JS.LBracket managers managerName)
82− (JS.ObjectLit () (managerEntries ++ otherEntries))
84+ (JS.Object (managerEntries ++ otherEntries))
83 in
85 in
84− [ JS.ExprStmt () addManager ]
86+ [ JS.ExprStmt addManager ]
85
87
86
88
87−(==>) :: String -> String -> ( JS.Prop (), JS.Expression () )
89+(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )
88(==>) key value =
90(==>) key value =
89− ( JS.PropId () (JS.Id () key)
91+ ( JS.IdProp (JS.Id key)
90− , JS.StringLit () value
92+ , JS.String value
91 )
93 )
src/Generate/JavaScript/BuiltIn.hs+38−35
@@ -1,5 +1,7 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
1module Generate.JavaScript.BuiltIn
3module Generate.JavaScript.BuiltIn
2− ( character, string
4+ ( character
3 , list, cons
5 , list, cons
4 , recordUpdate
6 , recordUpdate
5 , eq, cmp
7 , eq, cmp
@@ -8,52 +10,49 @@ module Generate.JavaScript.BuiltIn
8 )
10 )
9 where
11 where
10
12
11−import qualified Language.ECMAScript3.Syntax as JS
13+import qualified Data.Text as Text
14+import Data.Text (Text)
12
15
13import qualified AST.Module.Name as ModuleName
16import qualified AST.Module.Name as ModuleName
17+import qualified Generate.JavaScript.Builder as JS
14−import Generate.JavaScript.Helpers ((<|), (==>), call)
18+import Generate.JavaScript.Helpers ((<|), (==>))
15import qualified Generate.JavaScript.Variable as Var
19import qualified Generate.JavaScript.Variable as Var
16import qualified Reporting.Region as R
20import qualified Reporting.Region as R
17
21
18
22
19
23
20−utils :: String -> [JS.Expression ()] -> JS.Expression ()
24+utils :: Text -> [JS.Expr] -> JS.Expr
21utils func args =
25utils func args =
22− Var.coreNative "Utils" func `call` args
26+ JS.Call (Var.coreNative "Utils" func) args
23
27
24
28
25
29
26-- LITERALS
30-- LITERALS
27
31
28
32
29−character :: Char -> JS.Expression ()
33+character :: Char -> JS.Expr
30character char =
34character char =
31− utils "chr" [ JS.StringLit () [char] ]
35+ utils "chr" [ JS.String (Text.singleton char) ]
32−
33−
34−string :: String -> JS.Expression ()
35−string str =
36− JS.StringLit () str
37
36
38
37
39
38
40-- LISTS
39-- LISTS
41
40
42
41
43−list :: [JS.Expression ()] -> JS.Expression ()
42+list :: [JS.Expr] -> JS.Expr
44list elements =
43list elements =
45 case elements of
44 case elements of
46 [] ->
45 [] ->
47− JS.ObjectLit () [ "ctor" ==> JS.StringLit () "[]" ]
46+ JS.Object [ "ctor" ==> JS.String "[]" ]
48
47
49 front : back ->
48 front : back ->
50 cons front (list back)
49 cons front (list back)
51
50
52
51
53−cons :: JS.Expression () -> JS.Expression () -> JS.Expression ()
52+cons :: JS.Expr -> JS.Expr -> JS.Expr
54cons front back =
53cons front back =
55− JS.ObjectLit ()
54+ JS.Object
56− [ "ctor" ==> JS.StringLit () "::"
55+ [ "ctor" ==> JS.String "::"
57 , "_0" ==> front
56 , "_0" ==> front
58 , "_1" ==> back
57 , "_1" ==> back
59 ]
58 ]
@@ -63,11 +62,11 @@ cons front back =
63-- RECORDS
62-- RECORDS
64
63
65
64
66−recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()
65+recordUpdate :: JS.Expr -> [(Text, JS.Expr)] -> JS.Expr
67recordUpdate record fields =
66recordUpdate record fields =
68 utils "update"
67 utils "update"
69 [ record
68 [ record
70− , JS.ObjectLit () (map (uncurry (==>)) fields)
69+ , JS.Object (map (uncurry (==>)) fields)
71 ]
70 ]
72
71
73
72
@@ -75,12 +74,12 @@ recordUpdate record fields =
75-- COMPARISIONS
74-- COMPARISIONS
76
75
77
76
78−eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()
77+eq :: JS.Expr -> JS.Expr -> JS.Expr
79eq left right =
78eq left right =
80 utils "eq" [ left, right ]
79 utils "eq" [ left, right ]
81
80
82
81
83−cmp :: JS.Expression () -> JS.Expression () -> JS.Expression ()
82+cmp :: JS.Expr -> JS.Expr -> JS.Expr
84cmp left right =
83cmp left right =
85 utils "cmp" [ left, right ]
84 utils "cmp" [ left, right ]
86
85
@@ -89,31 +88,35 @@ cmp left right =
89-- EFFECTS
88-- EFFECTS
90
89
91
90
92−effect :: ModuleName.Canonical -> JS.Expression ()
91+effect :: ModuleName.Canonical -> JS.Expr
93effect effectName =
92effect effectName =
94 Var.coreNative "Platform" "leaf" <|
93 Var.coreNative "Platform" "leaf" <|
95− JS.StringLit () (ModuleName.canonicalToString effectName)
94+ JS.String (ModuleName.canonicalToText effectName)
96
95
97
96
98−outgoingPort :: String -> JS.Expression () -> JS.Expression ()
97+outgoingPort :: Text -> JS.Expr -> JS.Expr
99outgoingPort name converter =
98outgoingPort name converter =
99+ JS.Call
100− Var.coreNative "Platform" "outgoingPort" `call` [ JS.StringLit () name, converter ]
100+ (Var.coreNative "Platform" "outgoingPort")
101+ [ JS.String name, converter ]
101
102
102
103
103−incomingPort :: String -> JS.Expression () -> JS.Expression ()
104+incomingPort :: Text -> JS.Expr -> JS.Expr
104incomingPort name converter =
105incomingPort name converter =
106+ JS.Call
105− Var.coreNative "Platform" "incomingPort" `call` [ JS.StringLit () name, converter ]
107+ (Var.coreNative "Platform" "incomingPort")
108+ [ JS.String name, converter ]
106
109
107
110
108
111
109-- CRASH
112-- CRASH
110
113
111
114
112−crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expression ()) -> JS.Expression ()
115+crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expr) -> JS.Expr
113crash home region maybeCaseCrashValue =
116crash home region maybeCaseCrashValue =
114 let
117 let
115 homeString =
118 homeString =
116− JS.StringLit () (ModuleName.canonicalToString home)
119+ JS.String (ModuleName.canonicalToText home)
117 in
120 in
118 case maybeCaseCrashValue of
121 case maybeCaseCrashValue of
119 Nothing ->
122 Nothing ->
@@ -123,17 +126,17 @@ crash home region maybeCaseCrashValue =
123 utils "crashCase" [ homeString, regionToJs region, crashValue ]
126 utils "crashCase" [ homeString, regionToJs region, crashValue ]
124
127
125
128
126−regionToJs :: R.Region -> JS.Expression ()
129+regionToJs :: R.Region -> JS.Expr
127regionToJs (R.Region start end) =
130regionToJs (R.Region start end) =
128− JS.ObjectLit ()
131+ JS.Object
129 [ "start" ==> positionToJs start
132 [ "start" ==> positionToJs start
130 , "end" ==> positionToJs end
133 , "end" ==> positionToJs end
131 ]
134 ]
132
135
133
136
134−positionToJs :: R.Position -> JS.Expression ()
137+positionToJs :: R.Position -> JS.Expr
135positionToJs (R.Position line column) =
138positionToJs (R.Position line column) =
136− JS.ObjectLit ()
139+ JS.Object
137− [ "line" ==> JS.IntLit () line
140+ [ "line" ==> JS.Int line
138− , "column" ==> JS.IntLit () column
141+ , "column" ==> JS.Int column
139 ]
142 ]
src/Generate/JavaScript/Expression.hs+107−114
@@ -1,10 +1,13 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Generate.JavaScript.Expression (generateDef) where
2module Generate.JavaScript.Expression (generateDef) where
2
3
3import Control.Arrow (second)
4import Control.Arrow (second)
4import Control.Monad.State (State, foldM)
5import Control.Monad.State (State, foldM)
5import qualified Data.List as List
6import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7−import Language.ECMAScript3.Syntax
8+import Data.Monoid ((<>))
9+import qualified Data.Text as Text
10+import Data.Text (Text)
8
11
9import qualified AST.Expression.Canonical as Can
12import qualified AST.Expression.Canonical as Can
10import AST.Expression.Optimized as Opt
13import AST.Expression.Optimized as Opt
@@ -12,6 +15,7 @@ import qualified AST.Literal as L
12import qualified AST.Module.Name as ModuleName
15import qualified AST.Module.Name as ModuleName
13import qualified AST.Variable as Var
16import qualified AST.Variable as Var
14import Generate.JavaScript.Helpers as Help
17import Generate.JavaScript.Helpers as Help
18+import qualified Generate.JavaScript.Builder as JS
15import qualified Generate.JavaScript.BuiltIn as BuiltIn
19import qualified Generate.JavaScript.BuiltIn as BuiltIn
16import qualified Generate.JavaScript.Foreign as Foreign
20import qualified Generate.JavaScript.Foreign as Foreign
17import qualified Generate.JavaScript.Literal as Literal
21import qualified Generate.JavaScript.Literal as Literal
@@ -24,16 +28,16 @@ import qualified Optimize.DecisionTree as DT
24
28
25
29
26data Code
30data Code
27− = JsExpr (Expression ())
31+ = JsExpr JS.Expr
28− | JsBlock [Statement ()]
32+ | JsBlock [JS.Stmt]
29
33
30
34
31−jsExpr :: Expression () -> State Int Code
35+jsExpr :: JS.Expr -> State Int Code
32jsExpr exp =
36jsExpr exp =
33 return (JsExpr exp)
37 return (JsExpr exp)
34
38
35
39
36−jsBlock :: [Statement ()] -> State Int Code
40+jsBlock :: [JS.Stmt] -> State Int Code
37jsBlock exp =
41jsBlock exp =
38 return (JsBlock exp)
42 return (JsBlock exp)
39
43
@@ -45,44 +49,44 @@ isBlock code =
45 JsExpr _ -> False
49 JsExpr _ -> False
46
50
47
51
48−toStatementList :: Code -> [Statement ()]
52+toStatementList :: Code -> [JS.Stmt]
49toStatementList code =
53toStatementList code =
50 case code of
54 case code of
51 JsExpr expr ->
55 JsExpr expr ->
52− [ ReturnStmt () (Just expr) ]
56+ [ JS.Return (Just expr) ]
53
57
54 JsBlock stmts ->
58 JsBlock stmts ->
55 stmts
59 stmts
56
60
57
61
58−toStatement :: Code -> Statement ()
62+toStatement :: Code -> JS.Stmt
59toStatement code =
63toStatement code =
60 case code of
64 case code of
61 JsExpr expr ->
65 JsExpr expr ->
62− ReturnStmt () (Just expr)
66+ JS.Return (Just expr)
63
67
64 JsBlock [stmt] ->
68 JsBlock [stmt] ->
65 stmt
69 stmt
66
70
67 JsBlock stmts ->
71 JsBlock stmts ->
68− BlockStmt () stmts
72+ JS.Block stmts
69
73
70
74
71−toExpr :: Code -> Expression ()
75+toExpr :: Code -> JS.Expr
72toExpr code =
76toExpr code =
73 case code of
77 case code of
74 JsExpr expr ->
78 JsExpr expr ->
75− expr
79+ expr
76
80
77 JsBlock stmts ->
81 JsBlock stmts ->
78− function [] stmts `call` []
82+ JS.Call (function [] stmts) []
79
83
80
84
81
85
82-- DEFINITIONS
86-- DEFINITIONS
83
87
84
88
85−generateDef :: Opt.Def -> State Int [Statement ()]
89+generateDef :: Opt.Def -> State Int [JS.Stmt]
86generateDef def =
90generateDef def =
87 do (home, name, jsBody) <-
91 do (home, name, jsBody) <-
88 case def of
92 case def of
@@ -99,7 +103,7 @@ generateDef def =
99-- EXPRESSIONS
103-- EXPRESSIONS
100
104
101
105
102−generateJsExpr :: Opt.Expr -> State Int (Expression ())
106+generateJsExpr :: Opt.Expr -> State Int JS.Expr
103generateJsExpr optExpr =
107generateJsExpr optExpr =
104 toExpr <$> generateCode optExpr
108 toExpr <$> generateCode optExpr
105
109
@@ -114,8 +118,8 @@ generateCode expr =
114 jsExpr (Literal.literal lit)
118 jsExpr (Literal.literal lit)
115
119
116 Access record field ->
120 Access record field ->
117− do record' <- generateJsExpr record
121+ do jsRecord <- generateJsExpr record
118− jsExpr $ DotRef () record' (var (Var.safe field))
122+ jsExpr $ JS.DotRef jsRecord (JS.Id (Var.safe field))
119
123
120 Update record fields ->
124 Update record fields ->
121 let
125 let
@@ -134,7 +138,7 @@ generateCode expr =
134 return (Var.safe field ==> jsValue)
138 return (Var.safe field ==> jsValue)
135 in
139 in
136 do jsFields <- mapM toField fields
140 do jsFields <- mapM toField fields
137− jsExpr $ ObjectLit () jsFields
141+ jsExpr $ JS.Object jsFields
138
142
139 Binop op leftExpr rightExpr ->
143 Binop op leftExpr rightExpr ->
140 binop op leftExpr rightExpr
144 binop op leftExpr rightExpr
@@ -148,14 +152,15 @@ generateCode expr =
148 TailCall name argNames args ->
152 TailCall name argNames args ->
149 let
153 let
150 reassign name tempName =
154 reassign name tempName =
155+ JS.ExprStmt $
151− ExprStmt () (AssignExpr () OpAssign (LVar () (Var.safe name)) (ref tempName))
156+ JS.Assign JS.OpAssign (JS.LVar (Var.safe name)) (ref tempName)
152 in
157 in
153 do args' <- mapM generateJsExpr args
158 do args' <- mapM generateJsExpr args
154 tempNames <- mapM (\_ -> Var.fresh) args
159 tempNames <- mapM (\_ -> Var.fresh) args
155 jsBlock $
160 jsBlock $
156− VarDeclStmt () (zipWith varDecl tempNames args')
161+ JS.VarDeclStmt (zipWith varDecl tempNames args')
157 : zipWith reassign argNames tempNames
162 : zipWith reassign argNames tempNames
158− ++ [ContinueStmt () (Just (Id () (Var.safe name)))]
163+ ++ [JS.Continue (Just (JS.Id (Var.safe name)))]
159
164
160 Let defs body ->
165 Let defs body ->
161 do stmts <- mapM generateDef defs
166 do stmts <- mapM generateDef defs
@@ -175,17 +180,17 @@ generateCode expr =
175 Ctor tag members ->
180 Ctor tag members ->
176 let
181 let
177 ctor =
182 ctor =
178− "ctor" ==> StringLit () tag
183+ "ctor" ==> JS.String tag
179
184
180 toEntry entry n =
185 toEntry entry n =
181− ("_" ++ show n) ==> entry
186+ ("_" <> Text.pack (show n)) ==> entry
182 in
187 in
183 do jsMembers <- mapM generateJsExpr members
188 do jsMembers <- mapM generateJsExpr members
184− jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
189+ jsExpr $ JS.Object (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
185
190
186 CtorAccess dataExpr index ->
191 CtorAccess dataExpr index ->
187 do jsDataExpr <- generateJsExpr dataExpr
192 do jsDataExpr <- generateJsExpr dataExpr
188− jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
193+ jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
189
194
190 Cmd moduleName ->
195 Cmd moduleName ->
191 jsExpr $ BuiltIn.effect moduleName
196 jsExpr $ BuiltIn.effect moduleName
@@ -204,7 +209,7 @@ generateCode expr =
204 generateProgram kind body
209 generateProgram kind body
205
210
206 GLShader _uid src _tipe ->
211 GLShader _uid src _tipe ->
207− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
212+ jsExpr $ JS.Object [(JS.StringProp "src", Literal.literal (L.Str src))]
208
213
209 Crash home region maybeBranchProblem ->
214 Crash home region maybeBranchProblem ->
210 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
215 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
@@ -224,7 +229,7 @@ generateProgram kind body =
224
229
225 Can.NoFlags ->
230 Can.NoFlags ->
226 do almostProgram <- generateJsExpr body
231 do almostProgram <- generateJsExpr body
227− jsExpr (almostProgram `call` [])
232+ jsExpr (JS.Call almostProgram [])
228
233
229 Can.Flags tipe ->
234 Can.Flags tipe ->
230 do almostProgram <- generateJsExpr body
235 do almostProgram <- generateJsExpr body
@@ -236,22 +241,22 @@ generateProgram kind body =
236-- FUNCTIONS
241-- FUNCTIONS
237
242
238
243
239−generateFunction :: [String] -> Opt.Expr -> State Int Code
244+generateFunction :: [Text] -> Opt.Expr -> State Int Code
240generateFunction args body =
245generateFunction args body =
241 do code <- generateCode body
246 do code <- generateCode body
242 jsExpr (generateFunctionWithArity args code)
247 jsExpr (generateFunctionWithArity args code)
243
248
244
249
245−generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
250+generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr
246generateTailFunction name args body =
251generateTailFunction name args body =
247 do code <- generateCode body
252 do code <- generateCode body
248 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
253 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
249− LabelledStmt ()
254+ JS.Labelled
250− (Id () (Var.safe name))
255+ (JS.Id (Var.safe name))
251− (WhileStmt () (BoolLit () True) (toStatement code))
256+ (JS.While (JS.Bool True) (toStatement code))
252
257
253
258
254−generateFunctionWithArity :: [String] -> Code -> Expression ()
259+generateFunctionWithArity :: [Text] -> Code -> JS.Expr
255generateFunctionWithArity rawArgs code =
260generateFunctionWithArity rawArgs code =
256 let
261 let
257 args = map Var.safe rawArgs
262 args = map Var.safe rawArgs
@@ -259,7 +264,7 @@ generateFunctionWithArity rawArgs code =
259 in
264 in
260 if 2 <= arity && arity <= 9 then
265 if 2 <= arity && arity <= 9 then
261 let
266 let
262− fN = "F" ++ show arity
267+ fN = "F" <> Text.pack (show arity)
263 in
268 in
264 ref fN <| function args (toStatementList code)
269 ref fN <| function args (toStatementList code)
265 else
270 else
@@ -267,7 +272,7 @@ generateFunctionWithArity rawArgs code =
267 (lastArg:otherArgs) = reverse args
272 (lastArg:otherArgs) = reverse args
268 innerBody = function [lastArg] (toStatementList code)
273 innerBody = function [lastArg] (toStatementList code)
269 in
274 in
270− foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs
275+ foldl (\body arg -> function [arg] [JS.Return (Just body)]) innerBody otherArgs
271
276
272
277
273
278
@@ -281,7 +286,7 @@ generateCall func args =
281 case getUnaryOp var of
286 case getUnaryOp var of
282 Just op ->
287 Just op ->
283 do jsArg <- generateJsExpr arg
288 do jsArg <- generateJsExpr arg
284− jsExpr $ PrefixExpr () op jsArg
289+ jsExpr $ JS.Prefix op jsArg
285
290
286 Nothing ->
291 Nothing ->
287 generateCallHelp func args
292 generateCallHelp func args
@@ -291,7 +296,7 @@ generateCall func args =
291 Just (op, left, right) ->
296 Just (op, left, right) ->
292 do jsLeft <- generateJsExpr left
297 do jsLeft <- generateJsExpr left
293 jsRight <- generateJsExpr right
298 jsRight <- generateJsExpr right
294− jsExpr $ InfixExpr () op jsLeft jsRight
299+ jsExpr $ JS.Infix op jsLeft jsRight
295
300
296 Nothing ->
301 Nothing ->
297 generateCallHelp func args
302 generateCallHelp func args
@@ -304,58 +309,58 @@ generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
304generateCallHelp func args =
309generateCallHelp func args =
305 let
310 let
306 arity = length args
311 arity = length args
307− aN = "A" ++ show arity
312+ aN = "A" <> Text.pack (show arity)
308 in
313 in
309 do jsFunc <- generateJsExpr func
314 do jsFunc <- generateJsExpr func
310 jsArgs <- mapM generateJsExpr args
315 jsArgs <- mapM generateJsExpr args
311 jsExpr $
316 jsExpr $
312 if 2 <= arity && arity <= 9 then
317 if 2 <= arity && arity <= 9 then
313− ref aN `call` (jsFunc:jsArgs)
318+ JS.Call (ref aN) (jsFunc:jsArgs)
314 else
319 else
315 foldl1 (<|) (jsFunc:jsArgs)
320 foldl1 (<|) (jsFunc:jsArgs)
316
321
317
322
318−getUnaryOp :: Var.Canonical -> Maybe PrefixOp
323+getUnaryOp :: Var.Canonical -> Maybe JS.PrefixOp
319getUnaryOp var =
324getUnaryOp var =
320 if var == bitwiseComplement then
325 if var == bitwiseComplement then
321− Just PrefixBNot
326+ Just JS.PrefixBNot
322
327
323 else if var == basicsNot then
328 else if var == basicsNot then
324− Just PrefixLNot
329+ Just JS.PrefixLNot
325
330
326 else
331 else
327 Nothing
332 Nothing
328
333
329
334
330−getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (InfixOp, Opt.Expr, Opt.Expr)
335+getBinaryOp :: Var.Canonical -> Opt.Expr -> Opt.Expr -> Maybe (JS.InfixOp, Opt.Expr, Opt.Expr)
331getBinaryOp (Var.Canonical home name) left right =
336getBinaryOp (Var.Canonical home name) left right =
332 if home /= bitwise then
337 if home /= bitwise then
333 Nothing
338 Nothing
334
339
335 else
340 else
336 case name of
341 case name of
337− "and" -> Just ( OpBAnd, left, right )
342+ "and" -> Just ( JS.OpBAnd, left, right )
338− "or" -> Just ( OpBOr, left, right )
343+ "or" -> Just ( JS.OpBOr, left, right )
339− "xor" -> Just ( OpBXor, left, right )
344+ "xor" -> Just ( JS.OpBXor, left, right )
340− "shiftLeftBy" -> Just ( OpLShift, right, left )
345+ "shiftLeftBy" -> Just ( JS.OpLShift, right, left )
341− "shiftRightBy" -> Just ( OpSpRShift, right, left )
346+ "shiftRightBy" -> Just ( JS.OpSpRShift, right, left )
342− "shiftRightZfBy" -> Just ( OpZfRShift, right, left )
347+ "shiftRightZfBy" -> Just ( JS.OpZfRShift, right, left )
343 _ -> Nothing
348 _ -> Nothing
344
349
345
350
346bitwiseComplement :: Var.Canonical
351bitwiseComplement :: Var.Canonical
347bitwiseComplement =
352bitwiseComplement =
348− Var.inCore ["Bitwise"] "complement"
353+ Var.inCore "Bitwise" "complement"
349
354
350
355
351basicsNot :: Var.Canonical
356basicsNot :: Var.Canonical
352basicsNot =
357basicsNot =
353− Var.inCore ["Basics"] "not"
358+ Var.inCore "Basics" "not"
354
359
355
360
356bitwise :: Var.Home
361bitwise :: Var.Home
357bitwise =
362bitwise =
358− Var.Module (ModuleName.inCore ["Bitwise"])
363+ Var.Module (ModuleName.inCore "Bitwise")
359
364
360
365
361
366
@@ -372,10 +377,10 @@ generateIf givenBranches givenFinally =
372 (,) <$> generateJsExpr condition <*> generateCode expr
377 (,) <$> generateJsExpr condition <*> generateCode expr
373
378
374 ifExpression (condition, branch) otherwise =
379 ifExpression (condition, branch) otherwise =
375− CondExpr () condition branch otherwise
380+ JS.If condition branch otherwise
376
381
377 ifStatement (condition, branch) otherwise =
382 ifStatement (condition, branch) otherwise =
378− IfStmt () condition branch otherwise
383+ JS.IfStmt condition branch otherwise
379 in
384 in
380 do jsBranches <- mapM convertBranch branches
385 do jsBranches <- mapM convertBranch branches
381 jsFinally <- generateCode finally
386 jsFinally <- generateCode finally
@@ -421,11 +426,7 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
421-- CASE EXPRESSIONS
426-- CASE EXPRESSIONS
422
427
423
428
424−generateCase
425− :: String
426− -> Opt.Decider Opt.Choice
429+generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> State Int [JS.Stmt]
427− -> [(Int, Opt.Expr)]
428− -> State Int [Statement ()]
429generateCase exprName decider jumps =
430generateCase exprName decider jumps =
430 do labelRoot <- Var.fresh
431 do labelRoot <- Var.fresh
431 decider <- generateDecider exprName labelRoot decider
432 decider <- generateDecider exprName labelRoot decider
@@ -436,76 +437,68 @@ generateCase exprName decider jumps =
436-- handle any jumps
437-- handle any jumps
437
438
438
439
439−goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]
440+goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> State Int [JS.Stmt]
440goto labelRoot deciderStmts (target, branch) =
441goto labelRoot deciderStmts (target, branch) =
441 let
442 let
442 labeledDeciderStmt =
443 labeledDeciderStmt =
443− LabelledStmt ()
444+ JS.Labelled
444 (toLabel labelRoot target)
445 (toLabel labelRoot target)
445− (DoWhileStmt () (BlockStmt () deciderStmts) (BoolLit () False))
446+ (JS.DoWhile (JS.Block deciderStmts) (JS.Bool False))
446 in
447 in
447 do code <- generateCode branch
448 do code <- generateCode branch
448 return (labeledDeciderStmt : toStatementList code)
449 return (labeledDeciderStmt : toStatementList code)
449
450
450
451
451−toLabel :: String -> Int -> Id ()
452+toLabel :: Text -> Int -> JS.Id
452toLabel root target =
453toLabel root target =
453− Id () (root ++ "_" ++ show target)
454+ JS.Id (root <> "_" <> Text.pack (show target))
454
455
455
456
456
457
457-- turn deciders into ifs and switches
458-- turn deciders into ifs and switches
458
459
459
460
460−generateDecider
461− :: String
462− -> String
463− -> Opt.Decider Opt.Choice
461+generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> State Int [JS.Stmt]
464− -> State Int [Statement ()]
465generateDecider exprName labelRoot decisionTree =
462generateDecider exprName labelRoot decisionTree =
466 case decisionTree of
463 case decisionTree of
467 Opt.Leaf (Opt.Inline branch) ->
464 Opt.Leaf (Opt.Inline branch) ->
468 toStatementList <$> generateCode branch
465 toStatementList <$> generateCode branch
469
466
470 Opt.Leaf (Opt.Jump target) ->
467 Opt.Leaf (Opt.Jump target) ->
471− return [ BreakStmt () (Just (toLabel labelRoot target)) ]
468+ return [ JS.Break (Just (toLabel labelRoot target)) ]
472
469
473 Opt.Chain testChain success failure ->
470 Opt.Chain testChain success failure ->
474 let
471 let
475 makeTest (path, test) =
472 makeTest (path, test) =
476 do testExpr <- pathToTestableExpr exprName path test
473 do testExpr <- pathToTestableExpr exprName path test
477− return (InfixExpr () OpStrictEq testExpr (testToExpr test))
474+ return (JS.Infix JS.OpStrictEq testExpr (testToExpr test))
478 in
475 in
479 do testExprs <- mapM makeTest testChain
476 do testExprs <- mapM makeTest testChain
480− let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
477+ let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
481 thenBranch <- generateDecider exprName labelRoot success
478 thenBranch <- generateDecider exprName labelRoot success
482 elseBranch <- generateDecider exprName labelRoot failure
479 elseBranch <- generateDecider exprName labelRoot failure
483− return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
480+ return [ JS.IfStmt cond (JS.Block thenBranch) (JS.Block elseBranch) ]
484
481
485 Opt.FanOut path edges fallback ->
482 Opt.FanOut path edges fallback ->
486 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
483 do testExpr <- pathToTestableExpr exprName path (fst (head edges))
487− caseClauses <- mapM (edgeToCaseClause exprName labelRoot) edges
484+ caseClauses <- mapM (edgeToCase exprName labelRoot) edges
488− caseDefault <- CaseDefault () <$> generateDecider exprName labelRoot fallback
485+ caseDefault <- JS.Default <$> generateDecider exprName labelRoot fallback
489− return [ SwitchStmt () testExpr (caseClauses ++ [caseDefault]) ]
486+ return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
490
487
491
488
492−edgeToCaseClause
493− :: String
494− -> String
495− -> (DT.Test, Opt.Decider Opt.Choice)
489+edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> State Int JS.Case
496− -> State Int (CaseClause ())
497−edgeToCaseClause exprName labelRoot (test, subTree) =
490+edgeToCase exprName labelRoot (test, subTree) =
498− CaseClause () (testToExpr test) <$> generateDecider exprName labelRoot subTree
491+ JS.Case (testToExpr test) <$> generateDecider exprName labelRoot subTree
499
492
500
493
501−testToExpr :: DT.Test -> Expression ()
494+testToExpr :: DT.Test -> JS.Expr
502testToExpr test =
495testToExpr test =
503 case test of
496 case test of
504 DT.Constructor (Var.Canonical _ tag) ->
497 DT.Constructor (Var.Canonical _ tag) ->
505− StringLit () tag
498+ JS.String tag
506
499
507 DT.Literal (L.Chr char) ->
500 DT.Literal (L.Chr char) ->
508− StringLit () [char]
501+ JS.String (Text.singleton char)
509
502
510 DT.Literal lit ->
503 DT.Literal lit ->
511 Literal.literal lit
504 Literal.literal lit
@@ -515,21 +508,21 @@ testToExpr test =
515-- work with paths
508-- work with paths
516
509
517
510
518−pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
511+pathToTestableExpr :: Text -> DT.Path -> DT.Test -> State Int JS.Expr
519pathToTestableExpr root path exampleTest =
512pathToTestableExpr root path exampleTest =
520 do accessExpr <- generateJsExpr (pathToExpr root path)
513 do accessExpr <- generateJsExpr (pathToExpr root path)
521 case exampleTest of
514 case exampleTest of
522 DT.Constructor _ ->
515 DT.Constructor _ ->
523− return (DotRef () accessExpr (Id () "ctor"))
516+ return $ JS.DotRef accessExpr (JS.Id "ctor")
524
517
525 DT.Literal (L.Chr _) ->
518 DT.Literal (L.Chr _) ->
526− return (DotRef () accessExpr (Id () "valueOf") `call` [])
519+ return $ JS.Call (JS.DotRef accessExpr (JS.Id "valueOf")) []
527
520
528 DT.Literal _ ->
521 DT.Literal _ ->
529 return accessExpr
522 return accessExpr
530
523
531
524
532−pathToExpr :: String -> DT.Path -> Opt.Expr
525+pathToExpr :: Text -> DT.Path -> Opt.Expr
533pathToExpr root fullPath =
526pathToExpr root fullPath =
534 go (Opt.Var (Var.local root)) fullPath
527 go (Opt.Var (Var.local root)) fullPath
535 where
528 where
@@ -567,11 +560,11 @@ binop func left right =
567-- BINARY OPERATOR HELPERS
560-- BINARY OPERATOR HELPERS
568
561
569
562
570−binopHelp :: Var.Canonical -> Expression () -> Expression () -> Expression ()
563+binopHelp :: Var.Canonical -> JS.Expr -> JS.Expr -> JS.Expr
571binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
564binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
572 let
565 let
573 simpleMake left right =
566 simpleMake left right =
574− ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
567+ JS.Call (ref "A2") [ Var.canonical qualifiedOp, left, right ]
575 in
568 in
576 if home == basicsModule then
569 if home == basicsModule then
577 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
570 (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
@@ -585,52 +578,52 @@ binopHelp qualifiedOp@(Var.Canonical home op) leftExpr rightExpr =
585
578
586listModule :: Var.Home
579listModule :: Var.Home
587listModule =
580listModule =
588− Var.Module (ModuleName.inCore ["List"])
581+ Var.Module (ModuleName.inCore "List")
589
582
590
583
591listModuleInternals :: Var.Home
584listModuleInternals :: Var.Home
592listModuleInternals =
585listModuleInternals =
593− Var.TopLevel (ModuleName.inCore ["List"])
586+ Var.TopLevel (ModuleName.inCore "List")
594
587
595
588
596basicsModule :: Var.Home
589basicsModule :: Var.Home
597basicsModule =
590basicsModule =
598− Var.Module (ModuleName.inCore ["Basics"])
591+ Var.Module (ModuleName.inCore "Basics")
599
592
600
593
601−basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
594+basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)
602basicOps =
595basicOps =
603 Map.fromList (infixOps ++ specialOps)
596 Map.fromList (infixOps ++ specialOps)
604
597
605
598
606−infixOps :: [(String, Expression () -> Expression () -> Expression ())]
599+infixOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
607infixOps =
600infixOps =
608 let
601 let
609 infixOp str op =
602 infixOp str op =
610− (str, InfixExpr () op)
603+ (str, JS.Infix op)
611 in
604 in
612− [ infixOp "+" OpAdd
605+ [ infixOp "+" JS.OpAdd
613− , infixOp "-" OpSub
606+ , infixOp "-" JS.OpSub
614− , infixOp "*" OpMul
607+ , infixOp "*" JS.OpMul
615− , infixOp "/" OpDiv
608+ , infixOp "/" JS.OpDiv
616− , infixOp "&&" OpLAnd
609+ , infixOp "&&" JS.OpLAnd
617− , infixOp "||" OpLOr
610+ , infixOp "||" JS.OpLOr
618 ]
611 ]
619
612
620
613
621−specialOps :: [(String, Expression () -> Expression () -> Expression ())]
614+specialOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
622specialOps =
615specialOps =
623− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
616+ [ (,) "^" $ \a b -> JS.Call (obj ["Math","pow"]) [a,b]
624 , (,) "==" $ \a b -> BuiltIn.eq a b
617 , (,) "==" $ \a b -> BuiltIn.eq a b
625− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
618+ , (,) "/=" $ \a b -> JS.Prefix JS.PrefixLNot (BuiltIn.eq a b)
626− , (,) "<" $ cmp OpLT 0
619+ , (,) "<" $ cmp JS.OpLT 0
627− , (,) ">" $ cmp OpGT 0
620+ , (,) ">" $ cmp JS.OpGT 0
628− , (,) "<=" $ cmp OpLT 1
621+ , (,) "<=" $ cmp JS.OpLT 1
629− , (,) ">=" $ cmp OpGT (-1)
622+ , (,) ">=" $ cmp JS.OpGT (-1)
630− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
623+ , (,) "//" $ \a b -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
631 ]
624 ]
632
625
633
626
634−cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
627+cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
635cmp op n a b =
628cmp op n a b =
636− InfixExpr () op (BuiltIn.cmp a b) (IntLit () n)
629+ JS.Infix op (BuiltIn.cmp a b) (JS.Int n)
src/Generate/JavaScript/Foreign.hs+37−31
@@ -1,26 +1,32 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
1module Generate.JavaScript.Foreign (encode, decode) where
3module Generate.JavaScript.Foreign (encode, decode) where
2
4
5+import Prelude hiding (maybe)
3import qualified Data.List as List
6import qualified Data.List as List
4−import Language.ECMAScript3.Syntax
7+import qualified Data.Text as Text
8+import Data.Text (Text)
5
9
6import qualified AST.Expression.Optimized as Opt
10import qualified AST.Expression.Optimized as Opt
7import qualified AST.Literal as Literal
11import qualified AST.Literal as Literal
8import qualified AST.Type as T
12import qualified AST.Type as T
9import qualified AST.Variable as Var
13import qualified AST.Variable as Var
14+import qualified Generate.JavaScript.Builder as JS
10−import Generate.JavaScript.Helpers ((<|), (==>), function, ref, var)
15+import qualified Generate.JavaScript.Helpers as JS (function, ref)
11import qualified Generate.JavaScript.Variable as Var
16import qualified Generate.JavaScript.Variable as Var
17+import Generate.JavaScript.Helpers ((<|), (==>))
12
18
13
19
14
20
15-- ENCODE
21-- ENCODE
16
22
17
23
18−encode :: T.Canonical -> Expression ()
24+encode :: T.Canonical -> JS.Expr
19encode tipe =
25encode tipe =
20− function ["v"] [ ReturnStmt () (Just (encodeHelp tipe (ref "v"))) ]
26+ JS.function ["v"] [ JS.Return (Just (encodeHelp tipe (JS.ref "v"))) ]
21
27
22
28
23−encodeHelp :: T.Canonical -> Expression () -> Expression ()
29+encodeHelp :: T.Canonical -> JS.Expr -> JS.Expr
24encodeHelp tipe expr =
30encodeHelp tipe expr =
25 case tipe of
31 case tipe of
26 T.Aliased _ args t ->
32 T.Aliased _ args t ->
@@ -38,7 +44,7 @@ encodeHelp tipe expr =
38 | Var.isPrim "Bool" name -> expr
44 | Var.isPrim "Bool" name -> expr
39 | Var.isPrim "String" name -> expr
45 | Var.isPrim "String" name -> expr
40 | Var.isJson name -> expr
46 | Var.isJson name -> expr
41− | Var.isTuple name -> NullLit ()
47+ | Var.isTuple name -> JS.Null
42 | otherwise -> error "encodeHelp: bad type"
48 | otherwise -> error "encodeHelp: bad type"
43
49
44 T.App (T.Type name) [arg]
50 T.App (T.Type name) [arg]
@@ -58,45 +64,45 @@ encodeHelp tipe expr =
58
64
59 T.Record fields Nothing ->
65 T.Record fields Nothing ->
60 let
66 let
61− convert (name, tipe) =
67+ convert (k, t) =
62− name ==> encodeHelp tipe (DotRef () expr (var name))
68+ k ==> encodeHelp t (JS.DotRef expr (JS.Id k))
63 in
69 in
64− ObjectLit () (map convert fields)
70+ JS.Object (map convert fields)
65
71
66
72
67−fromMaybe :: T.Canonical -> Expression () -> Expression ()
73+fromMaybe :: T.Canonical -> JS.Expr -> JS.Expr
68fromMaybe tipe expr =
74fromMaybe tipe expr =
69− CondExpr ()
75+ JS.If
70− (InfixExpr () OpStrictEq (DotRef () expr (var "ctor")) (StringLit () "Nothing"))
76+ (JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing"))
71− (NullLit ())
77+ (JS.Null)
72− (encodeHelp tipe (DotRef () expr (var "_0")))
78+ (encodeHelp tipe (JS.DotRef expr (JS.Id "_0")))
73
79
74
80
75−fromList :: T.Canonical -> Expression () -> Expression ()
81+fromList :: T.Canonical -> JS.Expr -> JS.Expr
76fromList tipe expr =
82fromList tipe expr =
77 let
83 let
78 array =
84 array =
79 Var.coreNative "List" "toArray" <| expr
85 Var.coreNative "List" "toArray" <| expr
80 in
86 in
81− DotRef () array (var "map") <| encode tipe
87+ JS.DotRef array (JS.Id "map") <| encode tipe
82
88
83
89
84−fromArray :: T.Canonical -> Expression () -> Expression ()
90+fromArray :: T.Canonical -> JS.Expr -> JS.Expr
85fromArray tipe expr =
91fromArray tipe expr =
86 let
92 let
87 array =
93 array =
88 Var.coreNative "Array" "toJSArray" <| expr
94 Var.coreNative "Array" "toJSArray" <| expr
89 in
95 in
90− DotRef () array (var "map") <| encode tipe
96+ JS.DotRef array (JS.Id "map") <| encode tipe
91
97
92
98
93−fromTuple :: [T.Canonical] -> Expression () -> Expression ()
99+fromTuple :: [T.Canonical] -> JS.Expr -> JS.Expr
94fromTuple types expr =
100fromTuple types expr =
95 let
101 let
96 convert subType n =
102 convert subType n =
97− encodeHelp subType $ DotRef () expr (var ('_':show n))
103+ encodeHelp subType $ JS.DotRef expr (JS.Id (Text.pack ('_':show n)))
98 in
104 in
99− ArrayLit () (zipWith convert types [0..])
105+ JS.Array (zipWith convert types [ 0 .. length types ])
100
106
101
107
102
108
@@ -146,24 +152,24 @@ decode tipe =
146-- DECODE HELPERS
152-- DECODE HELPERS
147
153
148
154
149−inJsonDecode :: String -> Var.Canonical
155+inJsonDecode :: Text -> Var.Canonical
150inJsonDecode name =
156inJsonDecode name =
151− Var.inCore ["Json","Decode"] name
157+ Var.inCore "Json.Decode" name
152
158
153
159
154−to :: String -> Opt.Expr
160+to :: Text -> Opt.Expr
155to name =
161to name =
156 Opt.Var (inJsonDecode name)
162 Opt.Var (inJsonDecode name)
157
163
158
164
159−field :: String -> Opt.Expr -> Opt.Expr
165+field :: Text -> Opt.Expr -> Opt.Expr
160field name decoder =
166field name decoder =
161 to "field" <== [ Opt.Literal (Literal.Str name), decoder ]
167 to "field" <== [ Opt.Literal (Literal.Str name), decoder ]
162
168
163
169
164index :: Int -> Opt.Expr -> Opt.Expr
170index :: Int -> Opt.Expr -> Opt.Expr
165−index index decoder =
171+index i decoder =
166− to "index" <== [ Opt.Literal (Literal.IntNum index), decoder ]
172+ to "index" <== [ Opt.Literal (Literal.IntNum i), decoder ]
167
173
168
174
169(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
175(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
@@ -179,7 +185,7 @@ toMaybe :: T.Canonical -> Opt.Expr
179toMaybe tipe =
185toMaybe tipe =
180 let
186 let
181 maybe tag =
187 maybe tag =
182− Opt.Var (Var.inCore ["Maybe"] tag)
188+ Opt.Var (Var.inCore "Maybe" tag)
183 in
189 in
184 to "oneOf" <==
190 to "oneOf" <==
185 [ Opt.List
191 [ Opt.List
@@ -204,12 +210,12 @@ toTuple types =
204 zipWith (,) [ 0 .. size - 1] types
210 zipWith (,) [ 0 .. size - 1] types
205
211
206 toVar i =
212 toVar i =
207− 'x' : show i
213+ Text.pack ('x' : show i)
208
214
209 makeTuple =
215 makeTuple =
210 to "succeed" <==
216 to "succeed" <==
211 [ Opt.Ctor
217 [ Opt.Ctor
212− ("_Tuple" ++ show size)
218+ (Text.pack ("_Tuple" ++ show size))
213 (map (Opt.Var . Var.local . toVar . fst) pairs)
219 (map (Opt.Var . Var.local . toVar . fst) pairs)
214 ]
220 ]
215
221
@@ -219,7 +225,7 @@ toTuple types =
219 List.foldr andThen makeTuple pairs
225 List.foldr andThen makeTuple pairs
220
226
221
227
222−toRecord :: [(String, T.Canonical)] -> Opt.Expr
228+toRecord :: [(Text, T.Canonical)] -> Opt.Expr
223toRecord fields =
229toRecord fields =
224 let
230 let
225 toFieldExpr (key, _) =
231 toFieldExpr (key, _) =
src/Generate/JavaScript/Helpers.hs+23−35
@@ -1,68 +1,56 @@
1module Generate.JavaScript.Helpers where
1module Generate.JavaScript.Helpers where
2
2
3−import Language.ECMAScript3.Syntax
3+import Data.Text (Text)
4+import Generate.JavaScript.Builder
4
5
5
6
6
7
7−localRuntime :: String
8+-- DECLARATIONS
8−localRuntime =
9− "_elm"
10
9
11
10
12−varDecl :: String -> Expression () -> VarDecl ()
11+varDecl :: Text -> Expr -> VarDecl
13varDecl x expr =
12varDecl x expr =
14− VarDecl () (var x) (Just expr)
13+ VarDecl (Id x) (Just expr)
15
14
16
15
17−refOrObject :: String -> Expression ()
16+refOrObject :: Text -> Expr
18refOrObject name =
17refOrObject name =
19− InfixExpr () OpLOr (ref name) (ObjectLit () [])
18+ Infix OpLOr (ref name) (Object [])
20
19
21
20
22
21
23−-- Creating Variables
22+-- VARIABLES
24
23
25
24
26−var :: String -> Id ()
25+ref :: Text -> Expr
27−var name =
28− Id () name
29−
30−
31−ref :: String -> Expression ()
32ref name =
26ref name =
33− VarRef () (var name)
27+ VarRef (Id name)
34
28
35
29
36−(==>) :: String -> Expression () -> (Prop (), Expression ())
30+(==>) :: Text -> Expr -> (Prop, Expr)
37(==>) name expr =
31(==>) name expr =
38− ( PropId () (var name), expr )
32+ ( IdProp (Id name), expr )
39
33
40
34
41−obj :: [String] -> Expression ()
35+obj :: [Text] -> Expr
42obj vars =
36obj vars =
43− case vars of
37+ case vars of
44− x:xs ->
38+ x:xs ->
45− foldl (DotRef ()) (ref x) (map var xs)
39+ foldl DotRef (ref x) (map Id xs)
46
40
47− [] ->
41+ [] ->
48− error "dotSep must be called on a non-empty list of variables"
42+ error "dotSep must be called on a non-empty list of variables"
49
43
50
44
51
45
52−-- Function Calls
46+-- FUNCTION CALLS
53
47
54
48
55−(<|) :: Expression () -> Expression () -> Expression ()
49+(<|) :: Expr -> Expr -> Expr
56(<|) f x =
50(<|) f x =
57− CallExpr () f [x]
51+ Call f [x]
58
52
59
53
60−function :: [String] -> [Statement ()] -> Expression ()
54+function :: [Text] -> [Stmt] -> Expr
61function args stmts =
55function args stmts =
62− FuncExpr () Nothing (map var args) stmts
56+ Function Nothing (map Id args) stmts
63−
64−
65−call :: Expression () -> [Expression ()] -> Expression ()
66−call =
67− CallExpr ()
68−
src/Generate/JavaScript/Variable.hs+36−39
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Variable
3module Generate.JavaScript.Variable
3 ( fresh
4 ( fresh
4 , canonical
5 , canonical
@@ -12,14 +13,16 @@ module Generate.JavaScript.Variable
12 where
13 where
13
14
14import qualified Control.Monad.State as State
15import qualified Control.Monad.State as State
15−import qualified Data.List as List
16+import Data.Monoid
16import qualified Data.Set as Set
17import qualified Data.Set as Set
17−import qualified Language.ECMAScript3.Syntax as JS
18+import qualified Data.Text as Text
19+import Data.Text (Text)
18
20
19import qualified AST.Helpers as Help
21import qualified AST.Helpers as Help
20import qualified AST.Module.Name as ModuleName
22import qualified AST.Module.Name as ModuleName
21import qualified AST.Variable as Var
23import qualified AST.Variable as Var
22import qualified Elm.Package as Pkg
24import qualified Elm.Package as Pkg
25+import qualified Generate.JavaScript.Builder as JS
23import qualified Generate.JavaScript.Helpers as JS
26import qualified Generate.JavaScript.Helpers as JS
24
27
25
28
@@ -27,25 +30,25 @@ import qualified Generate.JavaScript.Helpers as JS
27-- FRESH NAMES
30-- FRESH NAMES
28
31
29
32
30−fresh :: State.State Int String
33+fresh :: State.State Int Text
31fresh =
34fresh =
32 do n <- State.get
35 do n <- State.get
33 State.modify (+1)
36 State.modify (+1)
34− return ("_v" ++ show n)
37+ return (Text.pack ("_v" ++ show n))
35
38
36
39
37
40
38-- DEF NAMES
41-- DEF NAMES
39
42
40
43
41−define :: Maybe ModuleName.Canonical -> String -> JS.Expression () -> [JS.Statement ()]
44+define :: Maybe ModuleName.Canonical -> Text -> JS.Expr -> [JS.Stmt]
42define maybeHome name body =
45define maybeHome name body =
43− if not (Help.isOp name) then
46+ if not (Help.isOp (Text.unpack name)) then
44 let
47 let
45 jsName =
48 jsName =
46 maybe unqualified qualified maybeHome name
49 maybe unqualified qualified maybeHome name
47 in
50 in
48− [ JS.VarDeclStmt () [ JS.varDecl jsName body ] ]
51+ [ JS.VarDeclStmt [ JS.varDecl jsName body ] ]
49
52
50 else
53 else
51 case maybeHome of
54 case maybeHome of
@@ -58,10 +61,10 @@ define maybeHome name body =
58 getOpsDictName (Var.TopLevel home)
61 getOpsDictName (Var.TopLevel home)
59
62
60 lvalue =
63 lvalue =
61− JS.LBracket () (JS.ref opsDictName) (JS.StringLit () name)
64+ JS.LBracket (JS.ref opsDictName) (JS.String name)
62 in
65 in
63− [ JS.VarDeclStmt () [ JS.varDecl opsDictName (JS.refOrObject opsDictName) ]
66+ [ JS.VarDeclStmt [ JS.varDecl opsDictName (JS.refOrObject opsDictName) ]
64− , JS.ExprStmt () (JS.AssignExpr () JS.OpAssign lvalue body)
67+ , JS.ExprStmt (JS.Assign JS.OpAssign lvalue body)
65 ]
68 ]
66
69
67
70
@@ -69,10 +72,10 @@ define maybeHome name body =
69-- INSTANTIATE VARIABLES
72-- INSTANTIATE VARIABLES
70
73
71
74
72−canonical :: Var.Canonical -> JS.Expression ()
75+canonical :: Var.Canonical -> JS.Expr
73canonical (Var.Canonical home name) =
76canonical (Var.Canonical home name) =
74− if Help.isOp name then
77+ if Help.isOp (Text.unpack name) then
75− JS.BracketRef () (JS.ref (getOpsDictName home)) (JS.StringLit () name)
78+ JS.BracketRef (JS.ref (getOpsDictName home)) (JS.String name)
76
79
77 else
80 else
78 case home of
81 case home of
@@ -93,32 +96,32 @@ canonical (Var.Canonical home name) =
93 JS.ref (qualified moduleName name)
96 JS.ref (qualified moduleName name)
94
97
95
98
96−unqualified :: String -> String
99+unqualified :: Text -> Text
97unqualified =
100unqualified =
98 safe
101 safe
99
102
100
103
101−qualified :: ModuleName.Canonical -> String -> String
104+qualified :: ModuleName.Canonical -> Text -> Text
102qualified moduleName name =
105qualified moduleName name =
103− moduleToString moduleName ++ "$" ++ name
106+ moduleToText moduleName <> "$" <> name
104
107
105
108
106−native :: ModuleName.Canonical -> String -> JS.Expression ()
109+native :: ModuleName.Canonical -> Text -> JS.Expr
107native moduleName name =
110native moduleName name =
108− JS.obj [ moduleToString moduleName, name ]
111+ JS.obj [ moduleToText moduleName, name ]
109
112
110
113
111−coreNative :: String -> String -> JS.Expression ()
114+coreNative :: Text -> Text -> JS.Expr
112coreNative moduleName name =
115coreNative moduleName name =
113− native (ModuleName.inCore ["Native",moduleName]) name
116+ native (ModuleName.inCore ("Native." <> moduleName)) name
114
117
115
118
116−staticProgram :: JS.Expression ()
119+staticProgram :: JS.Expr
117staticProgram =
120staticProgram =
118− native (ModuleName.inVirtualDom ["Native","VirtualDom"]) "staticProgram"
121+ native (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram"
119
122
120
123
121−getOpsDictName :: Var.Home -> String
124+getOpsDictName :: Var.Home -> Text
122getOpsDictName home =
125getOpsDictName home =
123 let
126 let
124 moduleName =
127 moduleName =
@@ -128,39 +131,34 @@ getOpsDictName home =
128 Var.Module name -> name
131 Var.Module name -> name
129 Var.TopLevel name -> name
132 Var.TopLevel name -> name
130 in
133 in
131− moduleToString moduleName ++ "_ops"
134+ moduleToText moduleName <> "_ops"
132
135
133
136
134−moduleToString :: ModuleName.Canonical -> String
137+moduleToText :: ModuleName.Canonical -> Text
135−moduleToString (ModuleName.Canonical (Pkg.Name user project) moduleName) =
138+moduleToText (ModuleName.Canonical (Pkg.Name user project) moduleName) =
136 let
139 let
137 safeUser =
140 safeUser =
138− map (swap '-' '_') user
141+ Text.replace "-" "_" user
139
142
140 safeProject =
143 safeProject =
141− map (swap '-' '_') project
144+ Text.replace "-" "_" project
142
145
143 safeModuleName =
146 safeModuleName =
144− List.intercalate "_" moduleName
147+ Text.replace "." "_" moduleName
145 in
148 in
146− '_' : safeUser ++ "$" ++ safeProject ++ "$" ++ safeModuleName
149+ "_" <> safeUser <> "$" <> safeProject <> "$" <> safeModuleName
147−
148−
149−swap :: Char -> Char -> Char -> Char
150−swap from to c =
151− if c == from then to else c
152
150
153
151
154
152
155-- SAFE NAMES
153-- SAFE NAMES
156
154
157
155
158−safe :: String -> String
156+safe :: Text -> Text
159safe name =
157safe name =
160− if Set.member name jsReserveds then '$' : name else name
158+ if Set.member name jsReserveds then "$" <> name else name
161
159
162
160
163−jsReserveds :: Set.Set String
161+jsReserveds :: Set.Set Text
164jsReserveds =
162jsReserveds =
165 Set.fromList
163 Set.fromList
166 -- JS reserved words
164 -- JS reserved words
@@ -177,5 +175,4 @@ jsReserveds =
177 -- reserved by the Elm runtime system
175 -- reserved by the Elm runtime system
178 , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
176 , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
179 , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
177 , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
180− , JS.localRuntime
181 ]
178 ]