@@ -254,52 +254,91 @@ tco' = everywhere (mkT convert)
254 isSelfCall _ _ = False
254 isSelfCall _ _ = False
256magicDo :: Options -> JS -> JS
256magicDo :: Options -> JS -> JS
257−magicDo opts | optionsMagicDo opts = magicDo'
257+magicDo opts | optionsMagicDo opts = inlineST . magicDo'
258 | otherwise = id
258 | otherwise = id
261+-- Inline type class dictionaries for >>= and return for the Eff monad
265+-- Prelude[">>="](dict)(m1)(function(x) {
260magicDo' :: JS -> JS
276magicDo' :: JS -> JS
261magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
277magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
279+ -- The name of the function block which is added to denote a do block
263 fnName = "__do"
280 fnName = "__do"
264−
281+ -- Desugar monomorphic calls to >>= and return for the Eff monad
265 convert :: JS -> JS
282 convert :: JS -> JS
266 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
284 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
267 convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
286 convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
268 JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
287 JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
269 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
289 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
270 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
290 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
271 convert other = other
291 convert other = other
272−
292+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
273 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
293 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
274 isBind _ = False
294 isBind _ = False
275−
295+ -- Check if an expression represents a monomorphic call to return for the Eff monad
276 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
296 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
277 isReturn _ = False
297 isReturn _ = False
278−
298+ -- Check if an expression represents the polymorphic >>= function
279 isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
299 isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
280 isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
300 isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
281 isBindPoly _ = False
301 isBindPoly _ = False
282−
302+ -- Check if an expression represents the polymorphic return function
283 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
303 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
284 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
304 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
285 isRetPoly _ = False
305 isRetPoly _ = False
287 prelude = ModuleName (ProperName "Prelude")
307 prelude = ModuleName (ProperName "Prelude")
288 effModule = ModuleName (ProperName "Eff")
308 effModule = ModuleName (ProperName "Eff")
289−
309+ -- The name of the type class dictionary for the Monad Eff instance
290 Right (Ident effDictName) = mkDictionaryValueName
310 Right (Ident effDictName) = mkDictionaryValueName
291 effModule
311 effModule
292 (Qualified (Just prelude) (ProperName "Monad"))
312 (Qualified (Just prelude) (ProperName "Monad"))
293 (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
313 (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
294−
314+ -- Check if an expression represents the Monad Eff dictionary
295 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
315 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
296 isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
316 isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
297 isEffDict _ = False
317 isEffDict _ = False
298−
318+ -- Remove __do function applications which remain after desugaring
299 undo :: JS -> JS
319 undo :: JS -> JS
300 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
320 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
301 undo other = other
321 undo other = other
324+-- Inline functions in the ST module
327+inlineST = everywhere (mkT convert)
329+ convert (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
330+ JSObjectLiteral [("value", arg)]
331+ convert (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
332+ JSAccessor "value" ref
333+ convert (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
334+ JSAssignment (JSAccessor "value" ref) arg
335+ convert (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
336+ JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
337+ convert other = other
338+ -- Check if an expression represents a function in the ST module
339+ isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True
340+ isSTFunc _ _ = False
303collapseNestedBlocks :: JS -> JS
342collapseNestedBlocks :: JS -> JS
304collapseNestedBlocks = everywhere (mkT collapse)
343collapseNestedBlocks = everywhere (mkT collapse)