Bundle.hs

-- |
-- Bundles compiled PureScript modules for the browser.
--
-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
-- performs dead code elimination, filters empty modules,
-- and generates the final JavaScript bundle.
{-# LANGUAGE DeriveAnyClass #-}
module Language.PureScript.Bundle
  ( ModuleIdentifier(..)
  , ModuleType(..)
  , ErrorMessage(..)
  , printErrorMessage
  , ForeignModuleExports(..)
  , getExportedIdentifiers
  , ForeignModuleImports(..)
  , getImportedModules
  , Module
  ) where

import Prelude

import Control.DeepSeq (NFData)
import Control.Monad.Error.Class (MonadError(..))

import Data.Aeson ((.=))
import Data.Char (chr, digitToInt)
import Data.Foldable (fold)
import Data.Maybe (mapMaybe, maybeToList)
import Data.Aeson qualified as A
import Data.Text.Lazy qualified as LT

import GHC.Generics (Generic)

import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText)
import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..))
import Language.JavaScript.Process.Minify (minifyJS)

-- | The type of error messages. We separate generation and rendering of errors using a data
-- type, in case we need to match on error types later.
data ErrorMessage
  = UnsupportedModulePath String
  | InvalidTopLevel
  | UnableToParseModule String
  | UnsupportedImport
  | UnsupportedExport
  | ErrorInModule ModuleIdentifier ErrorMessage
  | MissingEntryPoint String
  | MissingMainModule String
  deriving (Show, Generic, NFData)

-- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
-- foreign modules.
data ModuleType
  = Regular
  | Foreign
  deriving (Show, Eq, Ord, Generic, NFData)

showModuleType :: ModuleType -> String
showModuleType Regular = "Regular"
showModuleType Foreign = "Foreign"

-- | A module is identified by its module name and its type.
data ModuleIdentifier = ModuleIdentifier String ModuleType
  deriving (Show, Eq, Ord, Generic, NFData)

instance A.ToJSON ModuleIdentifier where
  toJSON (ModuleIdentifier name mt) =
    A.object [ "name" .= name
             , "type" .= show mt
             ]

data Visibility
  = Public
  | Internal
  deriving (Show, Eq, Ord)

-- | A piece of code is identified by its module, its name, and whether it is an internal variable
-- or a public member. These keys are used to label vertices in the dependency graph.
type Key = (ModuleIdentifier, String, Visibility)

-- | An export is either a "regular export", which exports a name from the regular module we are in,
-- or a reexport of a declaration in the corresponding foreign module.
--
-- Regular exports are labelled, since they might re-export an operator with another name.
data ExportType
  = RegularExport String
  | ForeignReexport
  deriving (Show, Eq, Ord)

-- | There are four types of module element we are interested in:
--
-- 1) Import declarations and require statements
-- 2) Member declarations
-- 3) Export lists
-- 4) Everything else
--
-- Each is labelled with the original AST node which generated it, so that we can dump it back
-- into the output during codegen.
data ModuleElement
  = Import JSModuleItem String (Either String ModuleIdentifier)
  | Member JSStatement Visibility String JSExpression [Key]
  | ExportsList [(ExportType, String, JSExpression, [Key])]
  | Other JSStatement
  | Skip JSModuleItem
  deriving (Show)

instance A.ToJSON ModuleElement where
  toJSON = \case
    (Import _ name (Right target)) ->
      A.object [ "type"   .= A.String "Import"
               , "name"   .= name
               , "target" .= target
               ]
    (Import _ name (Left targetPath)) ->
      A.object [ "type"       .= A.String "Import"
               , "name"       .= name
               , "targetPath" .= targetPath
               ]
    (Member _ visibility name _ dependsOn) ->
      A.object [ "type"       .= A.String "Member"
               , "name"       .= name
               , "visibility" .= show visibility
               , "dependsOn"  .= map keyToJSON dependsOn
               ]
    (ExportsList exports) ->
      A.object [ "type"    .= A.String "ExportsList"
               , "exports" .= map exportToJSON exports
               ]
    (Other stmt) ->
      A.object [ "type" .= A.String "Other"
               , "js"   .= getFragment (JSAstStatement stmt JSNoAnnot)
               ]
    (Skip item) ->
      A.object [ "type" .= A.String "Skip"
               , "js"   .= getFragment (JSAstModule [item] JSNoAnnot)
               ]

    where

    keyToJSON (mid, member, visibility) =
      A.object [ "module"     .= mid
               , "member"     .= member
               , "visibility" .= show visibility
               ]

    exportToJSON (RegularExport sourceName, name, _, dependsOn) =
      A.object [ "type"       .= A.String "RegularExport"
               , "name"       .= name
               , "sourceName" .= sourceName
               , "dependsOn"  .= map keyToJSON dependsOn
               ]
    exportToJSON (ForeignReexport, name, _, dependsOn) =
      A.object [ "type"      .= A.String "ForeignReexport"
               , "name"      .= name
               , "dependsOn" .= map keyToJSON dependsOn
               ]

    getFragment = ellipsize . renderToText . minifyJS
      where
      ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text
      ellipsis = '\x2026'

-- | A module is just a list of elements of the types listed above.
data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show)

instance A.ToJSON Module where
  toJSON (Module moduleId filePath elements) =
    A.object [ "moduleId" .= moduleId
             , "filePath" .= filePath
             , "elements" .= elements
             ]

-- | Prepare an error message for consumption by humans.
printErrorMessage :: ErrorMessage -> [String]
printErrorMessage (UnsupportedModulePath s) =
  [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")."
  , "The following file names are supported:"
  , "  1) index.js (PureScript native modules)"
  , "  2) foreign.js (PureScript ES foreign modules)"
  , "  3) foreign.cjs (PureScript CommonJS foreign modules)"
  ]
printErrorMessage InvalidTopLevel =
  [ "Expected a list of source elements at the top level." ]
printErrorMessage (UnableToParseModule err) =
  [ "The module could not be parsed:"
  , err
  ]
printErrorMessage UnsupportedImport =
  [ "An import was unsupported."
  , "Modules can be imported with ES namespace imports declarations:"
  , "  import * as module from \"Module.Name\""
  , "Alternatively, they can be also be imported with the CommonJS require function:"
  , "  var module = require(\"Module.Name\")"
  ]
printErrorMessage UnsupportedExport =
  [ "An export was unsupported."
  , "Declarations can be exported as ES named exports:"
  , "  export var decl"
  , "Existing identifiers can be exported as well:"
  , "  export { name }"
  , "They can also be renamed on export:"
  , "  export { name as alias }"
  , "Alternatively, CommonJS exports can be defined in one of two ways:"
  , "  1) exports.name = value"
  , "  2) exports = { name: value }"
  ]
printErrorMessage (ErrorInModule mid e) =
  ("Error in module " ++ displayIdentifier mid ++ ":")
  : ""
  : map ("  " ++) (printErrorMessage e)
  where
    displayIdentifier (ModuleIdentifier name ty) =
      name ++ " (" ++ showModuleType ty ++ ")"
printErrorMessage (MissingEntryPoint mName) =
  [ "Could not find an ES module or CommonJS module for the specified entry point: " ++ mName
  ]
printErrorMessage (MissingMainModule mName) =
  [ "Could not find an ES module or CommonJS module for the specified main module: " ++ mName
  ]

-- String literals include the quote chars
fromStringLiteral :: JSExpression -> Maybe String
fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str
fromStringLiteral _ = Nothing

strValue :: String -> String
strValue str = go $ drop 1 str
  where
  go ('\\' : 'b' : xs) = '\b' : go xs
  go ('\\' : 'f' : xs) = '\f' : go xs
  go ('\\' : 'n' : xs) = '\n' : go xs
  go ('\\' : 'r' : xs) = '\r' : go xs
  go ('\\' : 't' : xs) = '\t' : go xs
  go ('\\' : 'v' : xs) = '\v' : go xs
  go ('\\' : '0' : xs) = '\0' : go xs
  go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs
    where
    a' = 16 * digitToInt a
    b' = digitToInt b
  go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs
    where
    a' = 16 * 16 * 16 * digitToInt a
    b' = 16 * 16 * digitToInt b
    c' = 16 * digitToInt c
    d' = digitToInt d
  go ('\\' : x : xs) = x : go xs
  go "\"" = ""
  go "'" = ""
  go (x : xs) = x : go xs
  go "" = ""

commaList :: JSCommaList a -> [a]
commaList JSLNil = []
commaList (JSLOne x) = [x]
commaList (JSLCons l _ x) = commaList l ++ [x]

trailingCommaList :: JSCommaTrailingList a -> [a]
trailingCommaList (JSCTLComma l _) = commaList l
trailingCommaList (JSCTLNone l) = commaList l

identName :: JSIdent -> Maybe String
identName (JSIdentName _ ident) = Just ident
identName _ = Nothing

exportStatementIdentifiers :: JSStatement -> [String]
exportStatementIdentifiers (JSVariable _ jsExpressions _) =
  varNames jsExpressions
exportStatementIdentifiers (JSConstant _ jsExpressions _) =
  varNames jsExpressions
exportStatementIdentifiers (JSLet _ jsExpressions _) =
  varNames jsExpressions
exportStatementIdentifiers (JSClass _ jsIdent _ _ _ _ _) =
  maybeToList . identName $ jsIdent
exportStatementIdentifiers (JSFunction _ jsIdent _ _ _ _ _) =
  maybeToList . identName $ jsIdent
exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) =
  maybeToList . identName $ jsIdent
exportStatementIdentifiers _ = []

varNames :: JSCommaList JSExpression -> [String]
varNames = mapMaybe varName . commaList
  where
  varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident
  varName _ = Nothing

data ForeignModuleExports =
  ForeignModuleExports
    { cjsExports :: [String]
    , esExports :: [String]
    } deriving (Show)

instance Semigroup ForeignModuleExports where
  (ForeignModuleExports cjsExports esExports) <> (ForeignModuleExports cjsExports' esExports') =
    ForeignModuleExports (cjsExports <> cjsExports') (esExports <> esExports')
instance Monoid ForeignModuleExports where
  mempty = ForeignModuleExports [] []

-- Get a list of all the exported identifiers from a foreign module.
--
-- TODO: what if we assign to exports.foo and then later assign to
-- module.exports (presumably overwriting exports.foo)?
getExportedIdentifiers :: forall m. (MonadError ErrorMessage m)
                          => String
                          -> JSAST
                          -> m ForeignModuleExports
getExportedIdentifiers mname top
  | JSAstModule jsModuleItems _ <- top = fold <$> traverse go jsModuleItems
  | otherwise = err InvalidTopLevel
  where
  err :: ErrorMessage -> m a
  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)

  go (JSModuleStatementListItem jsStatement)
    | Just props <- matchExportsAssignment jsStatement
    = do cjsExports <- traverse toIdent (trailingCommaList props)
         pure ForeignModuleExports{ cjsExports, esExports = [] }
    | Just (Public, name, _) <- matchMember jsStatement
    = pure ForeignModuleExports{ cjsExports = [name], esExports = [] }
    | otherwise
    = pure mempty
  go (JSModuleExportDeclaration _ jsExportDeclaration) =
    pure ForeignModuleExports{ cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration }
  go _ = pure mempty

  toIdent (JSPropertyNameandValue name _ [_]) =
    extractLabel' name
  toIdent _ =
    err UnsupportedExport

  extractLabel' = maybe (err UnsupportedExport) pure . extractLabel

  exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) =
    exportClauseIdentifiers jsExportClause
  exportDeclarationIdentifiers (JSExportLocals jsExportClause _) =
    exportClauseIdentifiers jsExportClause
  exportDeclarationIdentifiers (JSExport jsStatement _) =
    exportStatementIdentifiers jsStatement

  exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) =
    mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers

  exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent
  exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs

data ForeignModuleImports =
  ForeignModuleImports
    { cjsImports :: [String]
    , esImports :: [String]
    } deriving (Show)

instance Semigroup ForeignModuleImports where
  (ForeignModuleImports cjsImports esImports) <> (ForeignModuleImports cjsImports' esImports') =
    ForeignModuleImports (cjsImports <> cjsImports') (esImports <> esImports')
instance Monoid ForeignModuleImports where
  mempty = ForeignModuleImports [] []

-- Get a list of all the imported module identifiers from a foreign module.
getImportedModules :: forall m. (MonadError ErrorMessage m)
                          => String
                          -> JSAST
                          -> m ForeignModuleImports
getImportedModules mname top
  | JSAstModule jsModuleItems _ <- top = pure $ foldMap go jsModuleItems
  | otherwise = err InvalidTopLevel
  where
  err :: ErrorMessage -> m a
  err = throwError . ErrorInModule (ModuleIdentifier mname Foreign)

  go (JSModuleStatementListItem jsStatement)
    | Just (_, mid) <- matchRequire jsStatement
    = ForeignModuleImports{ cjsImports = [mid], esImports = [] }
  go (JSModuleImportDeclaration _ jsImportDeclaration) =
    ForeignModuleImports{ cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration] }
  go _ = mempty

  importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid
  importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid

-- Matches JS statements like this:
-- var ModuleName = require("file");
matchRequire :: JSStatement -> Maybe (String, String)
matchRequire stmt
  | JSVariable _ jsInit _ <- stmt
  , [JSVarInitExpression var varInit] <- commaList jsInit
  , JSIdentifier _ importName <- var
  , JSVarInit _ jsInitEx <- varInit
  , JSMemberExpression req _ argsE _ <- jsInitEx
  , JSIdentifier _ "require" <- req
  , [ Just importPath ] <- map fromStringLiteral (commaList argsE)
  = Just (importName, importPath)
  | otherwise
  = Nothing

-- Matches JS member declarations.
matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression)
matchMember stmt
  | Just (name, decl) <- matchInternalMember stmt
  = pure (Internal, name, decl)
  -- exports.foo = expr; exports["foo"] = expr;
  | JSAssignStatement e (JSAssign _) decl _ <- stmt
  , Just name <- exportsAccessor e
  = Just (Public, name, decl)
  | otherwise
  = Nothing

matchInternalMember :: JSStatement -> Maybe (String, JSExpression)
matchInternalMember stmt
  -- var foo = expr;
  | JSVariable _ jsInit _ <- stmt
  , [JSVarInitExpression var varInit] <- commaList jsInit
  , JSIdentifier _ name <- var
  , JSVarInit _ decl <- varInit
  = pure (name, decl)
  -- function foo(...args) { body }
  | JSFunction a0 jsIdent a1 args a2 body _ <- stmt
  , JSIdentName _ name <- jsIdent
  = pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body)
  | otherwise
  = Nothing

-- Matches exports.* or exports["*"] expressions and returns the property name.
exportsAccessor :: JSExpression -> Maybe String
exportsAccessor (JSMemberDot exports _ nm)
  | JSIdentifier _ "exports" <- exports
  , JSIdentifier _ name <- nm
  = Just name
exportsAccessor (JSMemberSquare exports _ nm _)
  | JSIdentifier _ "exports" <- exports
  , Just name <- fromStringLiteral nm
  = Just name
exportsAccessor _ = Nothing

-- Matches assignments to module.exports, like this:
-- module.exports = { ... }
matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList
matchExportsAssignment stmt
  | JSAssignStatement e (JSAssign _) decl _ <- stmt
  , JSMemberDot module' _ exports <- e
  , JSIdentifier _ "module" <- module'
  , JSIdentifier _ "exports" <- exports
  , JSObjectLiteral _ props _ <- decl
  = Just props
  | otherwise
  = Nothing

extractLabel :: JSPropertyName -> Maybe String
extractLabel (JSPropertyString _ nm) = Just $ strValue nm
extractLabel (JSPropertyIdent _ nm) = Just nm
extractLabel _ = Nothing