module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where
import Data.List (nub)
import Data.Maybe (fromJust, isJust)
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.JS.Optimizer.Common
import Language.PureScript.Options
import qualified Language.PureScript.Constants as C
magicDo :: Options -> JS -> JS
magicDo opts | optionsNoMagicDo opts = id
| otherwise = inlineST . magicDo'
magicDo' :: JS -> JS
magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
where
fnName = "__do"
convert :: JS -> JS
convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val
convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =
JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )
convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =
JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)
convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =
JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []
convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []
convert other = other
isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True
isBind _ = False
isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True
isPure _ = False
isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]
isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]
isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
undo :: JS -> JS
undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body
undo other = other
applyReturns :: JS -> JS
applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])
applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)
applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)
applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)
applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)
applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)
applyReturns other = other
inlineST :: JS -> JS
inlineST = everywhereOnJS convertBlock
where
convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =
let refs = nub . findSTRefsIn $ arg
usages = findAllSTUsagesIn arg
allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
convertBlock other = other
convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =
JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])
convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =
if agg then ref else JSAccessor s1 C.stRefValue ref
convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg
convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])
convert _ other = other
isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'
isSTFunc _ _ = False
findSTRefsIn = everythingOnJS (++) isSTRef
where
isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
isSTRef _ = []
findAllSTUsagesIn = everythingOnJS (++) isSTUsage
where
isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
isSTUsage _ = []
appearingIn ref = everythingOnJS (++) isVar
where
isVar e@(JSVar _ v) | v == ref = [e]
isVar _ = []
toVar (JSVar _ v) = Just v
toVar _ = Nothing