Foreign.hs

{-# LANGUAGE BangPatterns #-}

-- |
-- Simple dead call elimination in foreign modules.
module Language.PureScript.DCE.Foreign
  ( runForeignModuleDeadCodeElimination,
  )
where

import Data.Foldable (foldr')
import Data.Graph (graphFromEdges, reachable, transposeG)
import Data.List (nub)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Language.JavaScript.Parser.AST
  ( JSArrayElement (..),
    JSBlock (..),
    JSClassElement (..),
    JSClassHeritage (..),
    JSCommaList (..),
    JSCommaTrailingList (..),
    JSExportClause (..),
    JSExportDeclaration (..),
    JSExportSpecifier (..),
    JSExpression (..),
    JSIdent (..),
    JSMethodDefinition (..),
    JSModuleItem (..),
    JSObjectProperty (..),
    JSStatement (..),
    JSSwitchParts (..),
    JSTemplatePart (..),
    JSTryCatch (..),
    JSTryFinally (..),
    JSVarInitializer (..),
  )
import Language.PureScript.Names (Ident, runIdent)

-- | Filter export statements in a foreign module.  This is not 100% safe.  It
-- might remove declarations that are used somewhere in the foreign module (for
-- example by using @'eval'@).
runForeignModuleDeadCodeElimination :: [Ident] -> [JSModuleItem] -> [JSModuleItem]
runForeignModuleDeadCodeElimination is items = nub allReachable
  where
    allReachable :: [JSModuleItem]
    allReachable = do
      ePoint <- mapMaybe (vertexForKey . runIdent) is
      reachableNode <- reachable (transposeG graph) ePoint
      pure $ jsM $ fromVertex reachableNode

    -- Build a graph of exports statements.  Its initial set of edges point from
    -- an export statement to all other export statements that are using it.
    -- When checking if we need to include that vartex we just check if there is
    -- a path from a vertex to one of `entryPointVertices`.
    exps :: [JSModuleItem]
    exps = filter isExportModuleItem items

    (graph, fromVertex, vertexForKey) = graphFromEdges verts

    jsM :: (JSModuleItem, Text, [Text]) -> JSModuleItem
    jsM (a, _, _) = a

    verts :: [(JSModuleItem, Text, [Text])]
    verts = items >>= toVert
      where
        toVert :: JSModuleItem -> [(JSModuleItem, Text, [Text])]
        toVert item@(JSModuleExportDeclaration _ jsExportDec) = mkVertex item <$> exportNames jsExportDec
        toVert item@(JSModuleStatementListItem stmt) = mkVertex item <$> toplevelNames stmt
        toVert _ = []

        mkVertex :: JSModuleItem -> Text -> (JSModuleItem, Text, [Text])
        mkVertex item name =
          (item, name, foldr' (accumulateDependents name) [] exps)

        accumulateDependents :: Text -> JSModuleItem -> [Text] -> [Text]
        accumulateDependents name item acc =
          if isNameUsedByItem name item
            then exportedModuleItemName item ++ acc
            else acc

-- | foldr over `JSCommaList`
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)

toList :: JSCommaList a -> [a]
toList ls = foldrJSCommaList (:) ls []

toplevelNames :: JSStatement -> [Text]
toplevelNames (JSFunction _ (JSIdentName _ name) _ _ _ _ _) = [T.pack name]
toplevelNames (JSConstant _ exprs _) = catMaybes $ foldrJSCommaList (\name acc -> jsIdent name : acc) exprs []
toplevelNames _ = []

exportName' :: JSExportSpecifier -> Maybe Text
exportName' (JSExportSpecifier (JSIdentName _ name)) = Just $ T.pack name
exportName' _ = Nothing

jsIdent :: JSExpression -> Maybe Text
jsIdent (JSVarInitExpression ident _) = jsIdent ident
jsIdent (JSIdentifier _ i) = Just $ T.pack i
jsIdent (JSStringLiteral _ s) = Just $ T.pack s
jsIdent _ = Nothing

exportNames :: JSExportDeclaration -> [Text]
exportNames (JSExportLocals (JSExportClause _ names _) _) = catMaybes $ foldrJSCommaList (\ex exs -> exportName' ex : exs) names []
exportNames (JSExportFrom (JSExportClause _ names _) _ _) = catMaybes $ foldrJSCommaList (\ex exs -> exportName' ex : exs) names []
exportNames (JSExport (JSConstant _ names _) _) = catMaybes $ foldrJSCommaList (\name nms -> jsIdent name : nms) names []
exportNames (JSExport (JSFunction _ (JSIdentName _ name) _ _ _ _ _) _) = [T.pack name]
exportNames _ = []

isExportModuleItem :: JSModuleItem -> Bool
isExportModuleItem (JSModuleExportDeclaration _ _) = True
isExportModuleItem _ = False

exportedModuleItemName :: JSModuleItem -> [Text]
exportedModuleItemName (JSModuleExportDeclaration _ jsModuleExport) = exportNames jsModuleExport
exportedModuleItemName _ = []

isNameUsedByItem :: Text -> JSModuleItem -> Bool
isNameUsedByItem _ (JSModuleImportDeclaration _ _) = False
isNameUsedByItem _ (JSModuleExportDeclaration _ (JSExportFrom _ _ _)) = False
isNameUsedByItem name (JSModuleExportDeclaration _ decl@(JSExportLocals _ _)) = name `elem` exportNames decl
isNameUsedByItem name (JSModuleExportDeclaration _ (JSExport statement _)) = isNameUsedByStatement name statement
isNameUsedByItem name (JSModuleStatementListItem stmt) = isNameUsedByStatement name stmt

isNameUsedByStatement :: Text -> JSStatement -> Bool
isNameUsedByStatement name (JSStatementBlock _ block _ _) =
  any (isNameUsedByStatement name) block
isNameUsedByStatement _ (JSBreak _ _ _) = False
isNameUsedByStatement name (JSLet _ exprs _) =
  any (isNameUsedByExpr name) (toList exprs)
isNameUsedByStatement name (JSClass _ _ heritage _ cls _ _) =
  isNameUsedInHeritage name heritage || any (isNameUsedByClassElement name) cls
isNameUsedByStatement name (JSConstant _ exprs _) =
  any (isNameUsedByExpr name) (toList exprs)
isNameUsedByStatement _ (JSContinue _ _ _) = False
isNameUsedByStatement name (JSDoWhile _ stmt _ _ expr _ _) =
  isNameUsedByStatement name stmt || isNameUsedByExpr name expr
isNameUsedByStatement name (JSFor _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)
isNameUsedByStatement name (JSForIn _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForVar _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)
isNameUsedByStatement name (JSForLet _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)
isNameUsedByStatement name (JSForConst _ _ _ exprs1 _ exprs2 _ exprs3 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) (toList exprs1 ++ toList exprs2 ++ toList exprs3)
isNameUsedByStatement name (JSForVarIn _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForLetIn _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForConstIn _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForVarOf _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForLetOf _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForConstOf _ _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSForOf _ _ expr1 _ expr2 _ stmt) =
  isNameUsedByStatement name stmt || any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByStatement name (JSFunction _ _ _ exprs _ (JSBlock _ stmts _) _) =
  any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts
isNameUsedByStatement name (JSGenerator _ _ _ _ exprs _ (JSBlock _ stmts _) _) =
  any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts
isNameUsedByStatement name (JSIf _ _ expr _ stmt) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt
isNameUsedByStatement name (JSIfElse _ _ expr _ stmtIf _ stmtElse) =
  isNameUsedByExpr name expr || any (isNameUsedByStatement name) [stmtIf, stmtElse]
isNameUsedByStatement name (JSLabelled _ _ stmt) = isNameUsedByStatement name stmt
isNameUsedByStatement _ (JSEmptyStatement _) = False
isNameUsedByStatement name (JSExpressionStatement expr _) = isNameUsedByExpr name expr
isNameUsedByStatement name (JSAssignStatement lhs _ rhs _) = any (isNameUsedByExpr name) [lhs, rhs]
isNameUsedByStatement name (JSMethodCall expr _ exprs _ _) = any (isNameUsedByExpr name) (expr : toList exprs)
isNameUsedByStatement _ (JSReturn _ Nothing _) = False
isNameUsedByStatement name (JSReturn _ (Just expr) _) = isNameUsedByExpr name expr
isNameUsedByStatement name (JSSwitch _ _ expr _ _ cases _ _) =
  isNameUsedByExpr name expr || any (isNameUsedByCase name) cases
isNameUsedByStatement name (JSThrow _ expr _) = isNameUsedByExpr name expr
isNameUsedByStatement name (JSTry _ (JSBlock _ stmts _) tryCatch tryFinally) =
  any (isNameUsedByStatement name) stmts || any (isNameUsedByTryCatch name) tryCatch || isNameUsedByTryFinally name tryFinally
isNameUsedByStatement name (JSVariable _ exprs _) = any (isNameUsedByExpr name) (toList exprs)
isNameUsedByStatement name (JSWhile _ _ expr _ stmt) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt
isNameUsedByStatement name (JSWith _ _ expr _ stmt _) = isNameUsedByExpr name expr || isNameUsedByStatement name stmt

isNameUsedByExpr :: Text -> JSExpression -> Bool
isNameUsedByExpr name (JSIdentifier _ ident) = name == T.pack ident
isNameUsedByExpr _ (JSDecimal _ _) = False
isNameUsedByExpr _ (JSLiteral _ _) = False
isNameUsedByExpr _ (JSHexInteger _ _) = False
isNameUsedByExpr _ (JSOctal _ _) = False
isNameUsedByExpr _ (JSStringLiteral _ _) = False
isNameUsedByExpr _ (JSRegEx _ _) = False
isNameUsedByExpr name (JSArrayLiteral _ elems _) = any (isNameUsedByArrayElement name) elems
isNameUsedByExpr name (JSAssignExpression lhs _ rhs) = any (isNameUsedByExpr name) [lhs, rhs]
isNameUsedByExpr name (JSCallExpression expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)
isNameUsedByExpr name (JSCallExpressionDot expr1 _ expr2) = any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByExpr name (JSCallExpressionSquare expr1 _ expr2 _) = any (isNameUsedByExpr name) [expr1, expr2]
isNameUsedByExpr name (JSClassExpression _ _ heritage _ cls _) =
  isNameUsedInHeritage name heritage || any (isNameUsedByClassElement name) cls
isNameUsedByExpr name (JSCommaExpression expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2
isNameUsedByExpr name (JSExpressionBinary expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2
isNameUsedByExpr name (JSExpressionParen _ expr _) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSExpressionPostfix expr _) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSExpressionTernary cond _ yes _ no) = any (isNameUsedByExpr name) [cond, yes, no]
isNameUsedByExpr name (JSArrowExpression _ _ stmt) = isNameUsedByStatement name stmt
isNameUsedByExpr name (JSFunctionExpression _ _ _ exprs _ (JSBlock _ stmts _)) =
  any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts
isNameUsedByExpr name (JSGeneratorExpression _ _ _ _ exprs _ (JSBlock _ stmts _)) =
  any (isNameUsedByExpr name) (toList exprs) || any (isNameUsedByStatement name) stmts
isNameUsedByExpr name (JSMemberDot expr1 _ expr2) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2
isNameUsedByExpr name (JSMemberExpression expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)
isNameUsedByExpr name (JSMemberNew _ expr _ exprs _) = any (isNameUsedByExpr name) (expr : toList exprs)
isNameUsedByExpr name (JSMemberSquare expr1 _ expr2 _) = isNameUsedByExpr name expr1 || isNameUsedByExpr name expr2
isNameUsedByExpr name (JSNewExpression _ expr) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSObjectLiteral _ (JSCTLComma props _) _) = any (isNameUsedByObjectProperty name) (toList props)
isNameUsedByExpr name (JSObjectLiteral _ (JSCTLNone props) _) = any (isNameUsedByObjectProperty name) (toList props)
isNameUsedByExpr name (JSSpreadExpression _ expr) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSTemplateLiteral Nothing _ _ parts) = any (isNameUsedByTemplatePart name) parts
isNameUsedByExpr name (JSTemplateLiteral (Just expr) _ _ parts) = isNameUsedByExpr name expr || any (isNameUsedByTemplatePart name) parts
isNameUsedByExpr name (JSUnaryExpression _ expr) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSVarInitExpression expr initializer) = isNameUsedByExpr name expr || isNameUsedByVarInit name initializer
isNameUsedByExpr _ (JSYieldExpression _ Nothing) = False
isNameUsedByExpr name (JSYieldExpression _ (Just expr)) = isNameUsedByExpr name expr
isNameUsedByExpr name (JSYieldFromExpression _ _ expr) = isNameUsedByExpr name expr

isNameUsedInHeritage :: Text -> JSClassHeritage -> Bool
isNameUsedInHeritage _ JSExtendsNone = False
isNameUsedInHeritage name (JSExtends _ expr) = isNameUsedByExpr name expr

isNameUsedByClassElement :: Text -> JSClassElement -> Bool
isNameUsedByClassElement _ (JSClassSemi _) = False
isNameUsedByClassElement name (JSClassInstanceMethod defn) = isNameUsedByMethodDefinition name defn
isNameUsedByClassElement name (JSClassStaticMethod _ defn) = isNameUsedByMethodDefinition name defn

isNameUsedByMethodDefinition :: Text -> JSMethodDefinition -> Bool
isNameUsedByMethodDefinition name (JSMethodDefinition _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)
isNameUsedByMethodDefinition name (JSGeneratorMethodDefinition _ _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)
isNameUsedByMethodDefinition name (JSPropertyAccessor _ _ _ exprs _ _) = any (isNameUsedByExpr name) (toList exprs)

isNameUsedByCase :: Text -> JSSwitchParts -> Bool
isNameUsedByCase name (JSDefault _ _ stmts) = any (isNameUsedByStatement name) stmts
isNameUsedByCase name (JSCase _ expr _ stmts) = isNameUsedByExpr name expr || any (isNameUsedByStatement name) stmts

isNameUsedByTryCatch :: Text -> JSTryCatch -> Bool
isNameUsedByTryCatch name (JSCatch _ _ expr _ (JSBlock _ stmts _)) = isNameUsedByExpr name expr || any (isNameUsedByStatement name) stmts
isNameUsedByTryCatch name (JSCatchIf _ _ expr1 _ expr2 _ (JSBlock _ stmts _)) = any (isNameUsedByExpr name) [expr1, expr2] || any (isNameUsedByStatement name) stmts

isNameUsedByTryFinally :: Text -> JSTryFinally -> Bool
isNameUsedByTryFinally name (JSFinally _ (JSBlock _ stmts _)) = any (isNameUsedByStatement name) stmts
isNameUsedByTryFinally _ JSNoFinally = False

isNameUsedByArrayElement :: Text -> JSArrayElement -> Bool
isNameUsedByArrayElement _ (JSArrayComma _) = False
isNameUsedByArrayElement name (JSArrayElement expr) = isNameUsedByExpr name expr

isNameUsedByObjectProperty :: Text -> JSObjectProperty -> Bool
isNameUsedByObjectProperty name (JSPropertyNameandValue _ _ exprs) = any (isNameUsedByExpr name) exprs
isNameUsedByObjectProperty name (JSPropertyIdentRef _ ref) = name == T.pack ref
isNameUsedByObjectProperty name (JSObjectMethod mDef) = isNameUsedByMethodDefinition name mDef

isNameUsedByTemplatePart :: Text -> JSTemplatePart -> Bool
isNameUsedByTemplatePart name (JSTemplatePart expr _ _) = isNameUsedByExpr name expr

isNameUsedByVarInit :: Text -> JSVarInitializer -> Bool
isNameUsedByVarInit name (JSVarInit _ expr) = isNameUsedByExpr name expr
isNameUsedByVarInit _ JSVarInitNone = False