module Language.PureScript.Optimizer.MagicDo (
magicDo
) where
import Data.List (nub)
import Data.Maybe (fromJust, isJust)
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Names
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 ret [val]) []) | isReturn ret = val
convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
let JSReturn ret = last js in
JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
let JSReturn ret = last js in
JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )
convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
convert other = other
isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
isBind _ = False
isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
isReturn _ = False
isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
isBindPoly _ = False
isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
isRetPoly _ = False
isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True
isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name
isEffDict _ _ = False
undo :: JS -> JS
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
undo other = other
isJSReturn (JSReturn _) = True
isJSReturn _ = False
inlineST :: JS -> JS
inlineST = everywhereOnJS convertBlock
where
convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.runSTArray 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 f [arg]) | isSTFunc C.newSTRef f =
JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
if agg then ref else JSAccessor C.stRefValue ref
convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =
JSIndexer i arr
convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.pokeSTArray f =
JSAssignment (JSIndexer i arr) val
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