{-# LANGUAGE BangPatterns #-}
module Language.PureScript.DCE.Foreign
( dceForeignModule ) where
import Prelude.Compat
import Control.Monad
import Data.Graph
import Data.Foldable (foldr')
import Data.List (any, elem, filter)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Language.JavaScript.Parser.AST
( JSStatement(..)
, JSExpression(..)
, JSCommaList(..)
, JSBlock(..)
, JSSwitchParts(..)
, JSTryCatch(..)
, JSTryFinally(..)
, JSArrayElement(..)
, JSObjectProperty(..)
, JSCommaTrailingList(..)
)
import Language.PureScript.Names
foldrJSCommaList :: (a -> b -> b) -> JSCommaList a -> b -> b
foldrJSCommaList _ JSLNil b = b
foldrJSCommaList fn (JSLOne a) !b = fn a b
foldrJSCommaList fn (JSLCons as _ a) !b = foldrJSCommaList fn as (fn a b)
dceForeignModule :: [Ident] -> [JSStatement] -> [JSStatement]
dceForeignModule is stmts = filter filterExports stmts
where
filterExports :: JSStatement -> Bool
filterExports (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ x) _) _ _ _)
= fltr (unquote . T.pack $ x)
filterExports (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ x)) _ _ _)
= fltr (T.pack x)
filterExports _ = True
fltr :: Text -> Bool
fltr t = any (fromMaybe True . (path graph <$> vertexForKey t <*>) . Just) entryPointVertices
|| any (isUsedInStmt t) nonExps
exps :: [JSStatement]
exps = filter isExportStatement stmts
nonExps = filter (not . isExportStatement) stmts
(graph, _, vertexForKey) = graphFromEdges verts
verts :: [(JSStatement, Text, [Text])]
verts = mapMaybe toVert exps
where
toVert :: JSStatement -> Maybe (JSStatement, Text, [Text])
toVert s
| Just name <- exportStatementName s = Just (s, name, foldr' (fn name) [] exps)
| otherwise = Nothing
fn name s' nms
| isUsedInStmt name s'
, Just n <- exportStatementName s' = n:nms
| otherwise = nms
entryPointVertices :: [Vertex]
entryPointVertices = catMaybes $ do
(_, k, _) <- verts
guard $ k `elem` ns
return (vertexForKey k)
where
ns = runIdent <$> is
unquote :: Text -> Text
unquote = T.drop 1 . T.dropEnd 1
isExportStatement :: JSStatement -> Bool
isExportStatement (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ _)) _ _ _) = True
isExportStatement (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ _) _) _ _ _) = True
isExportStatement _ = False
exportStatementName :: JSStatement -> Maybe Text
exportStatementName (JSAssignStatement (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) _ _ _) = Just . T.pack $ i
exportStatementName (JSAssignStatement (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) _ _ _) = Just . unquote . T.pack $ i
exportStatementName _ = Nothing
isUsedInStmt :: Text -> JSStatement -> Bool
isUsedInStmt n (JSStatementBlock _ ss _ _) = any (isUsedInStmt n) ss
isUsedInStmt n (JSDoWhile _ stm _ _ e _ _) = isUsedInStmt n stm || isUsedInExpr n e
isUsedInStmt n (JSFor _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s
isUsedInStmt n (JSForIn _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s
isUsedInStmt n (JSForVar _ _ _ es1 _ es2 _ es3 _ s) = isUsedInExprs n es1 || isUsedInExprs n es2 || isUsedInExprs n es3 || isUsedInStmt n s
isUsedInStmt n (JSForVarIn _ _ _ e1 _ e2 _ s) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInStmt n s
isUsedInStmt n (JSFunction _ _ _ _ _ (JSBlock _ ss _) _) = any (isUsedInStmt n) ss
isUsedInStmt n (JSIf _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s
isUsedInStmt n (JSIfElse _ _ e _ s1 _ s2) = isUsedInExpr n e || isUsedInStmt n s1 || isUsedInStmt n s2
isUsedInStmt n (JSLabelled _ _ s) = isUsedInStmt n s
isUsedInStmt _ (JSEmptyStatement _) = False
isUsedInStmt n (JSExpressionStatement e _) = isUsedInExpr n e
isUsedInStmt n (JSAssignStatement e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInStmt n (JSMethodCall e _ es _ _) = isUsedInExpr n e || isUsedInExprs n es
isUsedInStmt n (JSReturn _ me _) = fromMaybe False (isUsedInExpr n <$> me)
isUsedInStmt n (JSSwitch _ _ e _ _ sps _ _) = isUsedInExpr n e || any (isUsedInSwitchParts n) sps
isUsedInStmt n (JSThrow _ e _) = isUsedInExpr n e
isUsedInStmt n (JSTry _ (JSBlock _ ss _) cs f) = any (isUsedInStmt n) ss || any (isUsedInTryCatch n) cs || isUsedInFinally n f
isUsedInStmt n (JSVariable _ es _) = isUsedInExprs n es
isUsedInStmt n (JSWhile _ _ e _ s) = isUsedInExpr n e || isUsedInStmt n s
isUsedInStmt n (JSWith _ _ e _ s _) = isUsedInExpr n e || isUsedInStmt n s
isUsedInStmt _ JSBreak{} = False
isUsedInStmt _ JSConstant{} = False
isUsedInStmt _ JSContinue{} = False
isUsedInExpr :: Text -> JSExpression -> Bool
isUsedInExpr n (JSMemberDot (JSIdentifier _ "exports") _ (JSIdentifier _ i)) = n == T.pack i
isUsedInExpr n (JSMemberDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSArrayLiteral _ as _) = any (isUsedInArrayElement n) as
isUsedInExpr n (JSAssignExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSCallExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es
isUsedInExpr n (JSCallExpressionDot e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSCallExpressionSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSExpressionBinary e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSExpressionParen _ e _) = isUsedInExpr n e
isUsedInExpr n (JSExpressionPostfix e _) = isUsedInExpr n e
isUsedInExpr n (JSExpressionTernary e1 _ e2 _ e3) = isUsedInExpr n e1 || isUsedInExpr n e2 || isUsedInExpr n e3
isUsedInExpr n (JSFunctionExpression _ _ _ _ _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss
isUsedInExpr n (JSMemberExpression e _ es _) = isUsedInExpr n e || isUsedInExprs n es
isUsedInExpr n (JSMemberNew _ e _ es _) = isUsedInExpr n e || isUsedInExprs n es
isUsedInExpr n (JSMemberSquare (JSIdentifier _ "exports") _ (JSStringLiteral _ i) _) = n == (unquote .T.pack $ i)
isUsedInExpr n (JSMemberSquare e1 _ e2 _) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExpr n (JSNewExpression _ e) = isUsedInExpr n e
isUsedInExpr n (JSObjectLiteral _ ops _) = foldrJSCommaList (\p b -> isUsedInObjectProperty n p || b) (fromCTList ops) False
where
fromCTList (JSCTLComma as _) = as
fromCTList (JSCTLNone as) = as
isUsedInExpr n (JSUnaryExpression _ e) = isUsedInExpr n e
isUsedInExpr n (JSVarInitExpression e _) = isUsedInExpr n e
isUsedInExpr _ JSIdentifier{} = False
isUsedInExpr _ JSDecimal{} = False
isUsedInExpr _ JSLiteral{} = False
isUsedInExpr _ JSHexInteger{} = False
isUsedInExpr _ JSOctal{} = False
isUsedInExpr _ JSStringLiteral{} = False
isUsedInExpr _ JSRegEx{} = False
isUsedInExpr n (JSCommaExpression e1 _ e2) = isUsedInExpr n e1 || isUsedInExpr n e2
isUsedInExprs :: Text -> JSCommaList JSExpression -> Bool
isUsedInExprs n es = foldrJSCommaList fn es False
where
fn :: JSExpression -> Bool -> Bool
fn e b = isUsedInExpr n e || b
isUsedInSwitchParts :: Text -> JSSwitchParts -> Bool
isUsedInSwitchParts n (JSCase _ e _ ss) = isUsedInExpr n e || any (isUsedInStmt n) ss
isUsedInSwitchParts n (JSDefault _ _ ss) = any (isUsedInStmt n) ss
isUsedInTryCatch :: Text -> JSTryCatch -> Bool
isUsedInTryCatch n (JSCatch _ _ e _ (JSBlock _ ss _)) = isUsedInExpr n e || any (isUsedInStmt n) ss
isUsedInTryCatch n (JSCatchIf _ _ e1 _ e2 _ (JSBlock _ ss _)) = isUsedInExpr n e1 || isUsedInExpr n e2 || any (isUsedInStmt n) ss
isUsedInFinally :: Text -> JSTryFinally -> Bool
isUsedInFinally n (JSFinally _ (JSBlock _ ss _)) = any (isUsedInStmt n) ss
isUsedInFinally _ JSNoFinally = False
isUsedInArrayElement :: Text -> JSArrayElement -> Bool
isUsedInArrayElement n (JSArrayElement e) = isUsedInExpr n e
isUsedInArrayElement _ JSArrayComma{} = False
isUsedInObjectProperty :: Text -> JSObjectProperty -> Bool
isUsedInObjectProperty n (JSPropertyAccessor _ _ _ es _ (JSBlock _ ss _)) = any (isUsedInExpr n) es || any (isUsedInStmt n) ss
isUsedInObjectProperty n (JSPropertyNameandValue _ _ es) = any (isUsedInExpr n) es