1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
module GHC.JS.Transform
( identsS
, identsV
, identsE
, jStgExprToJS
, jStgStatToJS
)
where
import GHC.Prelude
import GHC.JS.Ident
import GHC.JS.JStg.Syntax
import qualified GHC.JS.Syntax as JS
import Data.List (sortBy)
import GHC.Data.FastString
import GHC.Types.Unique.Map
import GHC.Types.Unique.FM
{-# INLINE identsS #-}
identsS :: JStgStat -> [Ident]
identsS = \case
DeclStat i e -> [i] ++ maybe [] identsE e
ReturnStat e -> identsE e
IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2
WhileStat _ e s -> identsE e ++ identsS s
ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body
ForInStat _ i e s -> [i] ++ identsE e ++ identsS s
SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s
where traverseCase (e,s) = identsE e ++ identsS s
TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3
BlockStat xs -> concatMap identsS xs
ApplStat e es -> identsE e ++ concatMap identsE es
UOpStat _op e -> identsE e
AssignStat e1 _op e2 -> identsE e1 ++ identsE e2
LabelStat _l s -> identsS s
BreakStat{} -> []
ContinueStat{} -> []
FuncStat i args body -> [i] ++ args ++ identsS body
{-# INLINE identsE #-}
identsE :: JStgExpr -> [Ident]
identsE = \case
ValExpr v -> identsV v
SelExpr e _i -> identsE e -- do not rename properties
IdxExpr e1 e2 -> identsE e1 ++ identsE e2
InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2
UOpExpr _ e -> identsE e
IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3
ApplExpr e es -> identsE e ++ concatMap identsE es
{-# INLINE identsV #-}
identsV :: JVal -> [Ident]
identsV = \case
JVar i -> [i]
JList xs -> concatMap identsE xs
JDouble{} -> []
JInt{} -> []
JStr{} -> []
JRegEx{} -> []
JBool{} -> []
JHash m -> concatMap identsE (nonDetEltsUniqMap m)
JFunc args s -> args ++ identsS s
--------------------------------------------------------------------------------
-- Translation
--
--------------------------------------------------------------------------------
jStgStatToJS :: JStgStat -> JS.JStat
jStgStatToJS = \case
DeclStat i rhs -> JS.DeclStat i $ fmap jStgExprToJS rhs
ReturnStat e -> JS.ReturnStat $ jStgExprToJS e
IfStat c t e -> JS.IfStat (jStgExprToJS c) (jStgStatToJS t) (jStgStatToJS e)
WhileStat is_do c e -> JS.WhileStat is_do (jStgExprToJS c) (jStgStatToJS e)
ForStat init p step body -> JS.ForStat (jStgStatToJS init) (jStgExprToJS p)
(jStgStatToJS step) (jStgStatToJS body)
ForInStat is_each i iter body -> JS.ForInStat (is_each) i (jStgExprToJS iter) (jStgStatToJS body)
SwitchStat struct ps def -> JS.SwitchStat
(jStgExprToJS struct)
(map (\(p1, p2) -> (jStgExprToJS p1, jStgStatToJS p2)) ps)
(jStgStatToJS def)
TryStat t i c f -> JS.TryStat (jStgStatToJS t) i (jStgStatToJS c) (jStgStatToJS f)
BlockStat bs -> JS.BlockStat $ map jStgStatToJS bs
ApplStat rator rand -> JS.ApplStat (jStgExprToJS rator) $ map jStgExprToJS rand
UOpStat rator rand -> JS.UOpStat (jStgUOpToJS rator) (jStgExprToJS rand)
AssignStat lhs op rhs -> JS.AssignStat (jStgExprToJS lhs) (jStgAOpToJS op) (jStgExprToJS rhs)
LabelStat lbl stmt -> JS.LabelStat lbl (jStgStatToJS stmt)
BreakStat m_l -> JS.BreakStat $! m_l
ContinueStat m_l -> JS.ContinueStat $! m_l
FuncStat i args body -> JS.FuncStat i args $ jStgStatToJS body
jStgExprToJS :: JStgExpr -> JS.JExpr
jStgExprToJS = \case
ValExpr v -> JS.ValExpr $ jStgValToJS v
SelExpr obj i -> JS.SelExpr (jStgExprToJS obj) i
IdxExpr o i -> JS.IdxExpr (jStgExprToJS o) (jStgExprToJS i)
InfixExpr op l r -> JS.InfixExpr (jStgOpToJS op) (jStgExprToJS l) (jStgExprToJS r)
UOpExpr op r -> JS.UOpExpr (jStgUOpToJS op) (jStgExprToJS r)
IfExpr c t e -> JS.IfExpr (jStgExprToJS c) (jStgExprToJS t) (jStgExprToJS e)
ApplExpr rator rands -> JS.ApplExpr (jStgExprToJS rator) $ map jStgExprToJS rands
jStgValToJS :: JVal -> JS.JVal
jStgValToJS = \case
JVar i -> JS.JVar i
JList xs -> JS.JList $ map jStgExprToJS xs
JDouble d -> JS.JDouble d
JInt i -> JS.JInt i
JStr s -> JS.JStr s
JRegEx f -> JS.JRegEx f
JBool b -> JS.JBool b
JHash m -> JS.JHash $ mapUniqMapM satHash m
where
satHash (i, x) = (i,) . (i,) $ jStgExprToJS x
compareHash (i,_) (j,_) = lexicalCompareFS i j
-- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided
mapUniqMapM f (UniqMap m) = UniqMap . listToUFM $ (map f . sortBy compareHash $ nonDetEltsUFM m)
JFunc args body -> JS.JFunc args $ jStgStatToJS body
jStgOpToJS :: Op -> JS.Op
jStgOpToJS = go
where
go EqOp = JS.EqOp
go StrictEqOp = JS.StrictEqOp
go NeqOp = JS.NeqOp
go StrictNeqOp = JS.StrictNeqOp
go GtOp = JS.GtOp
go GeOp = JS.GeOp
go LtOp = JS.LtOp
go LeOp = JS.LeOp
go AddOp = JS.AddOp
go SubOp = JS.SubOp
go MulOp = JS.MulOp
go DivOp = JS.DivOp
go ModOp = JS.ModOp
go LeftShiftOp = JS.LeftShiftOp
go RightShiftOp = JS.RightShiftOp
go ZRightShiftOp = JS.ZRightShiftOp
go BAndOp = JS.BAndOp
go BOrOp = JS.BOrOp
go BXorOp = JS.BXorOp
go LAndOp = JS.LAndOp
go LOrOp = JS.LOrOp
go InstanceofOp = JS.InstanceofOp
go InOp = JS.InOp
jStgUOpToJS :: UOp -> JS.UOp
jStgUOpToJS = go
where
go NotOp = JS.NotOp
go BNotOp = JS.BNotOp
go NegOp = JS.NegOp
go PlusOp = JS.PlusOp
go NewOp = JS.NewOp
go TypeofOp = JS.TypeofOp
go DeleteOp = JS.DeleteOp
go YieldOp = JS.YieldOp
go VoidOp = JS.VoidOp
go PreIncOp = JS.PreIncOp
go PostIncOp = JS.PostIncOp
go PreDecOp = JS.PreDecOp
go PostDecOp = JS.PostDecOp
jStgAOpToJS :: AOp -> JS.AOp
jStgAOpToJS AssignOp = JS.AssignOp
jStgAOpToJS AddAssignOp = JS.AddAssignOp
jStgAOpToJS SubAssignOp = JS.SubAssignOp
|
