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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
module GHC.JS.Transform
( identsS
, identsV
, identsE
-- * Saturation
, satJStat
, satJExpr
-- * Generic traversal (via compos)
, JMacro(..)
, JMGadt(..)
, Compos(..)
, composOp
, composOpM
, composOpM_
, composOpFold
)
where
import GHC.Prelude
import qualified GHC.JS.Syntax as Sat
import GHC.JS.Unsat.Syntax
import Data.Functor.Identity
import Control.Monad
import Data.List (sortBy)
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
import GHC.Types.Unique.Map
import GHC.Types.Unique.FM
{-# INLINE identsS #-}
identsS :: Sat.JStat -> [Ident]
identsS = \case
Sat.DeclStat i e -> [i] ++ maybe [] identsE e
Sat.ReturnStat e -> identsE e
Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2
Sat.WhileStat _ e s -> identsE e ++ identsS s
Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body
Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s
Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s
where traverseCase (e,s) = identsE e ++ identsS s
Sat.TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3
Sat.BlockStat xs -> concatMap identsS xs
Sat.ApplStat e es -> identsE e ++ concatMap identsE es
Sat.UOpStat _op e -> identsE e
Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2
Sat.LabelStat _l s -> identsS s
Sat.BreakStat{} -> []
Sat.ContinueStat{} -> []
Sat.FuncStat i args body -> [i] ++ args ++ identsS body
{-# INLINE identsE #-}
identsE :: Sat.JExpr -> [Ident]
identsE = \case
Sat.ValExpr v -> identsV v
Sat.SelExpr e _i -> identsE e -- do not rename properties
Sat.IdxExpr e1 e2 -> identsE e1 ++ identsE e2
Sat.InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2
Sat.UOpExpr _ e -> identsE e
Sat.IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3
Sat.ApplExpr e es -> identsE e ++ concatMap identsE es
{-# INLINE identsV #-}
identsV :: Sat.JVal -> [Ident]
identsV = \case
Sat.JVar i -> [i]
Sat.JList xs -> concatMap identsE xs
Sat.JDouble{} -> []
Sat.JInt{} -> []
Sat.JStr{} -> []
Sat.JRegEx{} -> []
Sat.JHash m -> concatMap identsE (nonDetEltsUniqMap m)
Sat.JFunc args s -> args ++ identsS s
{--------------------------------------------------------------------
Compos
--------------------------------------------------------------------}
-- | Compos and ops for generic traversal as defined over
-- the JMacro ADT.
-- | Utility class to coerce the ADT into a regular structure.
class JMacro a where
jtoGADT :: a -> JMGadt a
jfromGADT :: JMGadt a -> a
instance JMacro Ident where
jtoGADT = JMGId
jfromGADT (JMGId x) = x
instance JMacro JStat where
jtoGADT = JMGStat
jfromGADT (JMGStat x) = x
instance JMacro JExpr where
jtoGADT = JMGExpr
jfromGADT (JMGExpr x) = x
instance JMacro JVal where
jtoGADT = JMGVal
jfromGADT (JMGVal x) = x
-- | Union type to allow regular traversal by compos.
data JMGadt a where
JMGId :: Ident -> JMGadt Ident
JMGStat :: JStat -> JMGadt JStat
JMGExpr :: JExpr -> JMGadt JExpr
JMGVal :: JVal -> JMGadt JVal
composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b
composOp f = runIdentity . composOpM (Identity . f)
composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b)
composOpM = compos return ap
composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m ()
composOpM_ = composOpFold (return ()) (>>)
composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
newtype C b a = C { unC :: b }
class Compos t where
compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
-> (forall a. t a -> m (t a)) -> t c -> m (t c)
instance Compos JMGadt where
compos = jmcompos
jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c)
jmcompos ret app f' v =
case v of
JMGId _ -> ret v
JMGStat v' -> ret JMGStat `app` case v' of
DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e
ReturnStat i -> ret ReturnStat `app` f i
IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'
WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s
ForStat init p step body -> ret ForStat `app` f init `app` f p
`app` f step `app` f body
ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s
SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d
where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l
BlockStat xs -> ret BlockStat `app` mapM' f xs
ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs
TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2
UOpStat o e -> ret (UOpStat o) `app` f e
AssignStat e e' -> ret AssignStat `app` f e `app` f e'
UnsatBlock _ -> ret v'
ContinueStat l -> ret (ContinueStat l)
FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body
BreakStat l -> ret (BreakStat l)
LabelStat l s -> ret (LabelStat l) `app` f s
JMGExpr v' -> ret JMGExpr `app` case v' of
ValExpr e -> ret ValExpr `app` f e
SelExpr e e' -> ret SelExpr `app` f e `app` f e'
IdxExpr e e' -> ret IdxExpr `app` f e `app` f e'
InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e'
UOpExpr o e -> ret (UOpExpr o) `app` f e
IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e''
ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs
UnsatExpr _ -> ret v'
JMGVal v' -> ret JMGVal `app` case v' of
JVar i -> ret JVar `app` f i
JList xs -> ret JList `app` mapM' f xs
JDouble _ -> ret v'
JInt _ -> ret v'
JStr _ -> ret v'
JRegEx _ -> ret v'
JHash m -> ret JHash `app` m'
-- nonDetEltsUniqMap doesn't introduce nondeterminism here because the
-- elements are treated independently before being re-added to a UniqMap
where (ls, vs) = unzip (nonDetUniqMapToList m)
m' = ret (listToUniqMap . zip ls) `app` mapM' f vs
JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s
UnsatVal _ -> ret v'
where
mapM' :: forall a. (a -> m a) -> [a] -> m [a]
mapM' g = foldr (app . app (ret (:)) . g) (ret [])
mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a)
mapMaybeM' g = \case
Nothing -> ret Nothing
Just a -> app (ret Just) (g a)
f :: forall b. JMacro b => b -> m b
f x = ret jfromGADT `app` f' (jtoGADT x)
{--------------------------------------------------------------------
Saturation
--------------------------------------------------------------------}
-- | Given an optional prefix, fills in all free variable names with a supply
-- of names generated by the prefix.
satJStat :: Maybe FastString -> JStat -> Sat.JStat
satJStat str x = evalState (jsSaturateS x) (newIdentSupply str)
satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr
satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str)
jsSaturateS :: JStat -> State [Ident] Sat.JStat
jsSaturateS = \case
DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs
ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e
IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e
WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e
ForStat init p step body -> Sat.ForStat <$> jsSaturateS init <*> jsSaturateE p
<*> jsSaturateS step <*> jsSaturateS body
ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body
SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct
<*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps
<*> jsSaturateS def
TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f
BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs
ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand
UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand
AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> pure Sat.AssignOp <*> jsSaturateE rhs
LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt
BreakStat m_l -> return $ Sat.BreakStat $! m_l
ContinueStat m_l -> return $ Sat.ContinueStat $! m_l
FuncStat i args body -> Sat.FuncStat i args <$> jsSaturateS body
UnsatBlock us -> jsSaturateS =<< runIdentSupply us
jsSaturateE :: JExpr -> State [Ident] Sat.JExpr
jsSaturateE = \case
ValExpr v -> Sat.ValExpr <$> jsSaturateV v
SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i
IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i
InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r
UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r
IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e
ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands
UnsatExpr us -> jsSaturateE =<< runIdentSupply us
jsSaturateV :: JVal -> State [Ident] Sat.JVal
jsSaturateV = \case
JVar i -> return $ Sat.JVar i
JList xs -> Sat.JList <$> mapM jsSaturateE xs
JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d))
JInt i -> return $ Sat.JInt i
JStr s -> return $ Sat.JStr s
JRegEx f -> return $ Sat.JRegEx f
JHash m -> Sat.JHash <$> mapUniqMapM satHash m
where
satHash (i, x) = (i,) . (i,) <$> jsSaturateE 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 <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m)
JFunc args body -> Sat.JFunc args <$> jsSaturateS body
UnsatVal us -> jsSaturateV =<< runIdentSupply us
satJOp :: JOp -> Sat.Op
satJOp = go
where
go EqOp = Sat.EqOp
go StrictEqOp = Sat.StrictEqOp
go NeqOp = Sat.NeqOp
go StrictNeqOp = Sat.StrictNeqOp
go GtOp = Sat.GtOp
go GeOp = Sat.GeOp
go LtOp = Sat.LtOp
go LeOp = Sat.LeOp
go AddOp = Sat.AddOp
go SubOp = Sat.SubOp
go MulOp = Sat.MulOp
go DivOp = Sat.DivOp
go ModOp = Sat.ModOp
go LeftShiftOp = Sat.LeftShiftOp
go RightShiftOp = Sat.RightShiftOp
go ZRightShiftOp = Sat.ZRightShiftOp
go BAndOp = Sat.BAndOp
go BOrOp = Sat.BOrOp
go BXorOp = Sat.BXorOp
go LAndOp = Sat.LAndOp
go LOrOp = Sat.LOrOp
go InstanceofOp = Sat.InstanceofOp
go InOp = Sat.InOp
satJUOp :: JUOp -> Sat.UOp
satJUOp = go
where
go NotOp = Sat.NotOp
go BNotOp = Sat.BNotOp
go NegOp = Sat.NegOp
go PlusOp = Sat.PlusOp
go NewOp = Sat.NewOp
go TypeofOp = Sat.TypeofOp
go DeleteOp = Sat.DeleteOp
go YieldOp = Sat.YieldOp
go VoidOp = Sat.VoidOp
go PreIncOp = Sat.PreIncOp
go PostIncOp = Sat.PostIncOp
go PreDecOp = Sat.PreDecOp
go PostDecOp = Sat.PostDecOp
|