@@ -254,52 +254,91 @@ tco' = everywhere (mkT convert)
254254 isSelfCall _ _ = False
255255
256256magicDo :: Options -> JS -> JS
257−magicDo opts | optionsMagicDo opts = magicDo'
257+magicDo opts | optionsMagicDo opts = inlineST . magicDo'
258258 | otherwise = id
259259
260+-- |
261+-- Inline type class dictionaries for >>= and return for the Eff monad
262+--
263+-- E.g.
264+--
265+-- Prelude[">>="](dict)(m1)(function(x) {
266+-- return ...;
267+-- })
268+--
269+-- becomes
270+--
271+-- function __do {
272+-- var x = m1();
273+-- ...
274+-- }
275+--
260276magicDo' :: JS -> JS
261277magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
262278 where
279+ -- The name of the function block which is added to denote a do block
263280 fnName = "__do"
264−
281+ -- Desugar monomorphic calls to >>= and return for the Eff monad
265282 convert :: JS -> JS
283+ -- Desugar return
266284 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
285+ -- Desugae >>
267286 convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
268287 JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
288+ -- Desugar >>=
269289 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
270290 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
271291 convert other = other
272−
292+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
273293 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
274294 isBind _ = False
275−
295+ -- Check if an expression represents a monomorphic call to return for the Eff monad
276296 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
277297 isReturn _ = False
278−
298+ -- Check if an expression represents the polymorphic >>= function
279299 isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
280300 isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
281301 isBindPoly _ = False
282−
302+ -- Check if an expression represents the polymorphic return function
283303 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
284304 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
285305 isRetPoly _ = False
286−
306+ -- Module names
287307 prelude = ModuleName (ProperName "Prelude")
288308 effModule = ModuleName (ProperName "Eff")
289−
309+ -- The name of the type class dictionary for the Monad Eff instance
290310 Right (Ident effDictName) = mkDictionaryValueName
291311 effModule
292312 (Qualified (Just prelude) (ProperName "Monad"))
293313 (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
294−
314+ -- Check if an expression represents the Monad Eff dictionary
295315 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
296316 isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
297317 isEffDict _ = False
298−
318+ -- Remove __do function applications which remain after desugaring
299319 undo :: JS -> JS
300320 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
301321 undo other = other
302322
323+-- |
324+-- Inline functions in the ST module
325+--
326+inlineST :: JS -> JS
327+inlineST = everywhere (mkT convert)
328+ where
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
341+
303342collapseNestedBlocks :: JS -> JS
304343collapseNestedBlocks = everywhere (mkT collapse)
305344 where