@@ -0,0 +1,545 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : psc-bundle
4+-- Copyright : (c) Phil Freeman 2015
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Bundles compiled PureScript modules for the browser.
12+--
13+-- This module takes as input the individual generated modules from 'Language.PureScript.Make' and
14+-- performs dead code elimination, filters empty modules,
15+-- and generates the final Javascript bundle.
16+-----------------------------------------------------------------------------
17+
18+{-# LANGUAGE PatternGuards #-}
19+{-# LANGUAGE FlexibleContexts #-}
20+{-# LANGUAGE ScopedTypeVariables #-}
21+{-# LANGUAGE TupleSections #-}
22+{-# LANGUAGE RecordWildCards #-}
23+
24+module Language.PureScript.Bundle (
25+ bundle
26+ , ModuleIdentifier(..)
27+ , moduleName
28+ , ModuleType(..)
29+ , ErrorMessage(..)
30+ , printErrorMessage
31+) where
32+
33+import Data.List (nub)
34+import Data.Maybe (mapMaybe, catMaybes)
35+import Data.Generics (everything, everywhere, mkQ, mkT)
36+import Data.Graph
37+import Data.Version (showVersion)
38+
39+import qualified Data.Set as S
40+
41+import Control.Applicative
42+import Control.Monad
43+import Control.Monad.Error.Class
44+import Language.JavaScript.Parser
45+
46+import qualified Paths_purescript as Paths
47+
48+-- | The type of error messages. We separate generation and rendering of errors using a data
49+-- type, in case we need to match on error types later.
50+data ErrorMessage
51+ = UnsupportedModulePath String
52+ | InvalidTopLevel
53+ | UnableToParseModule String
54+ | UnsupportedExport
55+ | ErrorInModule ModuleIdentifier ErrorMessage
56+ deriving Show
57+
58+-- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules.
59+data ModuleType
60+ = Regular
61+ | Foreign
62+ deriving (Show, Eq, Ord)
63+
64+-- | A module is identified by its module name and its type.
65+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
66+
67+moduleName :: ModuleIdentifier -> String
68+moduleName (ModuleIdentifier name _) = name
69+
70+-- | A piece of code is identified by its module and its name. These keys are used to label vertices
71+-- in the dependency graph.
72+type Key = (ModuleIdentifier, String)
73+
74+-- | An export is either a "regular export", which exports a name from the regular module we are in,
75+-- or a reexport of a declaration in the corresponding foreign module.
76+--
77+-- Regular exports are labelled, since they might re-export an operator with another name.
78+data ExportType
79+ = RegularExport String
80+ | ForeignReexport
81+ deriving (Show, Eq, Ord)
82+
83+-- | There are four types of module element we are interested in:
84+--
85+-- 1) Require statements
86+-- 2) Member declarations
87+-- 3) Export lists
88+-- 4) Everything else
89+--
90+-- Each is labelled with the original AST node which generated it, so that we can dump it back
91+-- into the output during codegen.
92+data ModuleElement
93+ = Require JSNode String ModuleIdentifier
94+ | Member JSNode Bool String [JSNode] [Key]
95+ | ExportsList [(ExportType, String, JSNode, [Key])]
96+ | Other JSNode
97+ deriving Show
98+
99+-- | A module is just a list of elements of the types listed above.
100+data Module = Module ModuleIdentifier [ModuleElement] deriving Show
101+
102+-- | Prepare an error message for consumption by humans.
103+printErrorMessage :: ErrorMessage -> [String]
104+printErrorMessage (UnsupportedModulePath s) =
105+ [ "A CommonJS module has an unsupported name (" ++ show s ++ ")."
106+ , "The following file names are supported:"
107+ , " 1) index.js (psc native modules)"
108+ , " 2) foreign.js (psc foreign modules)"
109+ ]
110+printErrorMessage InvalidTopLevel =
111+ [ "Expected a list of source elements at the top level." ]
112+printErrorMessage (UnableToParseModule err) =
113+ [ "The module could not be parsed:"
114+ , err
115+ ]
116+printErrorMessage UnsupportedExport =
117+ [ "An export was unsupported. Exports can be defined in one of two ways: "
118+ , " 1) exports.name = ..."
119+ , " 2) exports = { ... }"
120+ ]
121+printErrorMessage (ErrorInModule mid e) =
122+ ("Error in module " ++ displayIdentifier mid ++ ":")
123+ : ""
124+ : map (" " ++) (printErrorMessage e)
125+ where
126+ displayIdentifier (ModuleIdentifier name ty) =
127+ name ++ " (" ++ show ty ++ ")"
128+
129+-- | Unpack the node inside a JSNode. This is useful when pattern matching.
130+node :: JSNode -> Node
131+node (NN n) = n
132+node (NT n _ _) = n
133+
134+-- | Calculate the ModuleIdentifier which a require(...) statement imports.
135+checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier
136+checkImportPath "./foreign" m _ =
137+ Just (ModuleIdentifier (moduleName m) Foreign)
138+checkImportPath name _ names
139+ | name `S.member` names = Just (ModuleIdentifier name Regular)
140+checkImportPath _ _ _ = Nothing
141+
142+-- | Compute the dependencies of all elements in a module, and add them to the tree.
143+--
144+-- Members and exports can have dependencies. A dependency is of one of the following forms:
145+--
146+-- 1) module.name or member["name"]
147+--
148+-- where module was imported using
149+--
150+-- var module = require("Module.Name");
151+--
152+-- 2) name
153+--
154+-- where name is the name of a member defined in the current module.
155+withDeps :: Module -> Module
156+withDeps (Module modulePath es) = Module modulePath (map expandDeps es)
157+ where
158+ -- | Collects all modules which are imported, so that we can identify dependencies of the first type.
159+ imports :: [(String, ModuleIdentifier)]
160+ imports = mapMaybe toImport es
161+ where
162+ toImport :: ModuleElement -> Maybe (String, ModuleIdentifier)
163+ toImport (Require _ nm mid) = Just (nm, mid)
164+ toImport _ = Nothing
165+
166+ -- | Collects all member names in scope, so that we can identify dependencies of the second type.
167+ boundNames :: [String]
168+ boundNames = mapMaybe toBoundName es
169+ where
170+ toBoundName :: ModuleElement -> Maybe String
171+ toBoundName (Member _ _ nm _ _) = Just nm
172+ toBoundName _ = Nothing
173+
174+ -- | Calculate dependencies and add them to the current element.
175+ expandDeps :: ModuleElement -> ModuleElement
176+ expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl))
177+ expandDeps (ExportsList exps) = ExportsList (map expand exps)
178+ where
179+ expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1))
180+ expandDeps other = other
181+
182+ dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)]
183+ dependencies m = everything (++) (mkQ [] toReference)
184+ where
185+ toReference :: Node -> [(ModuleIdentifier, String)]
186+ toReference (JSMemberDot [ mn ] _ nm)
187+ | JSIdentifier mn' <- node mn
188+ , JSIdentifier nm' <- node nm
189+ , Just mid <- lookup mn' imports
190+ = [(mid, nm')]
191+ toReference (JSMemberSquare [ mn ] _ nm _)
192+ | JSIdentifier mn' <- node mn
193+ , JSExpression [ s ] <- node nm
194+ , JSStringLiteral _ nm' <- node s
195+ , Just mid <- lookup mn' imports
196+ = [(mid, nm')]
197+ toReference (JSIdentifier nm)
198+ | nm `elem` boundNames
199+ = [(m, nm)]
200+ toReference _ = []
201+
202+-- | Attempt to create a Module from a Javascript AST.
203+--
204+-- Each type of module element is matched using pattern guards, and everything else is bundled into the
205+-- Other constructor.
206+toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module
207+toModule mids mid top
208+ | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns
209+ | otherwise = err InvalidTopLevel
210+ where
211+ err = throwError . ErrorInModule mid
212+
213+ toModuleElement :: JSNode -> m ModuleElement
214+ toModuleElement n
215+ | JSVariables var [ varIntro ] _ <- node n
216+ , JSLiteral "var" <- node var
217+ , JSVarDecl impN [ eq, req, impP ] <- node varIntro
218+ , JSIdentifier importName <- node impN
219+ , JSLiteral "=" <- node eq
220+ , JSIdentifier "require" <- node req
221+ , JSArguments _ [ impS ] _ <- node impP
222+ , JSStringLiteral _ importPath <- node impS
223+ , Just importPath' <- checkImportPath importPath mid mids
224+ = pure (Require n importName importPath')
225+ toModuleElement n
226+ | JSVariables var [ varIntro ] _ <- node n
227+ , JSLiteral "var" <- node var
228+ , JSVarDecl declN (eq : decl) <- node varIntro
229+ , JSIdentifier name <- node declN
230+ , JSLiteral "=" <- node eq
231+ = pure (Member n False name decl [])
232+ toModuleElement n
233+ | JSExpression (e : op : decl) <- node n
234+ , Just name <- accessor (node e)
235+ , JSOperator eq <- node op
236+ , JSLiteral "=" <- node eq
237+ = pure (Member n True name decl [])
238+ where
239+ accessor :: Node -> Maybe String
240+ accessor (JSMemberDot [ exports ] _ nm)
241+ | JSIdentifier "exports" <- node exports
242+ , JSIdentifier name <- node nm
243+ = Just name
244+ accessor (JSMemberSquare [ exports ] _ nm _)
245+ | JSIdentifier "exports" <- node exports
246+ , JSExpression [e] <- node nm
247+ , JSStringLiteral _ name <- node e
248+ = Just name
249+ accessor _ = Nothing
250+ toModuleElement n
251+ | JSExpression (mnExp : op : obj: _) <- node n
252+ , JSMemberDot [ mn ] _ e <- node mnExp
253+ , JSIdentifier "module" <- node mn
254+ , JSIdentifier "exports" <- node e
255+ , JSOperator eq <- node op
256+ , JSLiteral "=" <- node eq
257+ , JSObjectLiteral _ props _ <- node obj
258+ = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props))
259+ where
260+ toExport :: Node -> m (ExportType, String, JSNode, [Key])
261+ toExport (JSPropertyNameandValue name _ [val] ) =
262+ (,,val,[]) <$> exportType (node val)
263+ <*> extractLabel (node name)
264+ toExport _ = err UnsupportedExport
265+
266+ exportType :: Node -> m ExportType
267+ exportType (JSMemberDot [f] _ _)
268+ | JSIdentifier "$foreign" <- node f
269+ = pure ForeignReexport
270+ exportType (JSMemberSquare [f] _ _ _)
271+ | JSIdentifier "$foreign" <- node f
272+ = pure ForeignReexport
273+ exportType (JSIdentifier s) = pure (RegularExport s)
274+ exportType _ = err UnsupportedExport
275+
276+ extractLabel :: Node -> m String
277+ extractLabel (JSStringLiteral _ nm) = pure nm
278+ extractLabel (JSIdentifier nm) = pure nm
279+ extractLabel _ = err UnsupportedExport
280+
281+ isSeparator :: Node -> Bool
282+ isSeparator (JSLiteral ",") = True
283+ isSeparator _ = False
284+ toModuleElement other = pure (Other other)
285+
286+-- | Eliminate unused code based on the specified entry point set.
287+compile :: [Module] -> [ModuleIdentifier] -> [Module]
288+compile modules [] = modules
289+compile modules entryPoints = filteredModules
290+ where
291+ (graph, _, vertexFor) = graphFromEdges verts
292+
293+ -- | The vertex set
294+ verts :: [(ModuleElement, Key, [Key])]
295+ verts = do
296+ Module mid els <- modules
297+ concatMap (toVertices mid) els
298+ where
299+ -- | Create a set of vertices for a module element.
300+ --
301+ -- Some special cases worth commenting on:
302+ --
303+ -- 1) Regular exports which simply export their own name do not count as dependencies.
304+ -- Regular exports which rename and reexport an operator do count, however.
305+ --
306+ -- 2) Require statements don't contribute towards dependencies, since they effectively get
307+ -- inlined wherever they are used inside other module elements.
308+ toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
309+ toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)]
310+ toVertices p m@(ExportsList exps) = mapMaybe toVertex exps
311+ where
312+ toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks)
313+ toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks)
314+ toVertex _ = Nothing
315+ toVertices _ _ = []
316+
317+ -- | The set of vertices whose connected components we are interested in keeping.
318+ entryPointVertices :: [Vertex]
319+ entryPointVertices = catMaybes $ do
320+ (_, k@(mid, _), _) <- verts
321+ guard $ mid `elem` entryPoints
322+ return (vertexFor k)
323+
324+ -- | The set of vertices reachable from an entry point
325+ reachableSet :: S.Set Vertex
326+ reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices)
327+
328+ filteredModules :: [Module]
329+ filteredModules = map filterUsed modules
330+ where
331+ filterUsed :: Module -> Module
332+ filterUsed (Module mid ds) = Module mid (map filterExports (go ds))
333+ where
334+ go :: [ModuleElement] -> [ModuleElement]
335+ go [] = []
336+ go (d : Other semi : rest)
337+ | JSLiteral ";" <- node semi
338+ , not (isDeclUsed d)
339+ = go rest
340+ go (d : rest)
341+ | not (isDeclUsed d) = go rest
342+ | otherwise = d : go rest
343+
344+ -- | Filter out the exports for members which aren't used.
345+ filterExports :: ModuleElement -> ModuleElement
346+ filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps)
347+ filterExports me = me
348+
349+ isDeclUsed :: ModuleElement -> Bool
350+ isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm)
351+ isDeclUsed _ = True
352+
353+ isKeyUsed :: Key -> Bool
354+ isKeyUsed k
355+ | Just me <- vertexFor k = me `S.member` reachableSet
356+ | otherwise = False
357+
358+-- | Topologically sort the module dependency graph, so that when we generate code, modules can be
359+-- defined in the right order.
360+sortModules :: [Module] -> [Module]
361+sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph))
362+ where
363+ (graph, nodeFor, _) = graphFromEdges $ do
364+ m@(Module mid els) <- modules
365+ return (m, mid, mapMaybe getKey els)
366+
367+ getKey :: ModuleElement -> Maybe ModuleIdentifier
368+ getKey (Require _ _ mi) = Just mi
369+ getKey _ = Nothing
370+
371+-- | A module is empty if it contains no exported members (in other words,
372+-- if the only things left after dead code elimination are module imports and
373+-- "other" foreign code).
374+--
375+-- If a module is empty, we don't want to generate code for it.
376+isModuleEmpty :: Module -> Bool
377+isModuleEmpty (Module _ els) = all isElementEmpty els
378+ where
379+ isElementEmpty :: ModuleElement -> Bool
380+ isElementEmpty (ExportsList exps) = null exps
381+ isElementEmpty (Require _ _ _) = True
382+ isElementEmpty (Other _) = True
383+ isElementEmpty _ = False
384+
385+-- | Generate code for a set of modules, including a call to main().
386+--
387+-- Modules get defined on the global PS object, as follows:
388+--
389+-- var PS = { };
390+-- (function(exports) {
391+-- ...
392+-- })(PS["Module.Name"] = PS["Module.Name"] || {});
393+--
394+-- In particular, a module and its foreign imports share the same namespace inside PS.
395+-- This saves us from having to generate unique names for a module and its foreign imports,
396+-- and is safe since a module shares a namespace with its foreign imports in PureScript as well
397+-- (so there is no way to have overlaps in code generated by psc).
398+codeGen :: Maybe String -- ^ main module
399+ -> String -- ^ namespace
400+ -> [Module] -- ^ input modules
401+ -> String
402+codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule)))
403+ where
404+ moduleToJS :: Module -> [JSNode]
405+ moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds))
406+ where
407+ declToJS :: ModuleElement -> [JSNode]
408+ declToJS (Member n _ _ _ _) = [n]
409+ declToJS (Other n) = [n]
410+ declToJS (Require _ nm req) =
411+ [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ])
412+ [ NN (JSVarDecl (sp (JSIdentifier nm))
413+ [ sp (JSLiteral "=")
414+ , moduleReference sp (moduleName req)
415+ ])
416+ ]
417+ (nt (JSLiteral ";"))) ]
418+ declToJS (ExportsList exps) = map toExport exps
419+
420+ where
421+ toExport :: (ExportType, String, JSNode, [Key]) -> JSNode
422+ toExport (_, nm, val, _) =
423+ NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ]
424+ (nt (JSLiteral "["))
425+ (NN (JSExpression [ nt (JSStringLiteral '"' nm) ]))
426+ (nt (JSLiteral "]")))
427+ , NN (JSOperator (sp (JSLiteral "=")))
428+ , reindent val
429+ , nt (JSLiteral ";")
430+ ])
431+
432+ reindent :: JSNode -> JSNode
433+ reindent (NT n _ _) = sp n
434+ reindent nn = nn
435+
436+ indent :: [JSNode] -> [JSNode]
437+ indent = everywhere (mkT squash)
438+ where
439+ squash (NT n pos ann) = NT n (keepCol pos) (map splat ann)
440+ squash nn = nn
441+
442+ splat (CommentA pos s) = CommentA (keepCol pos) s
443+ splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w
444+ splat ann = ann
445+
446+ keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2)
447+
448+ prelude :: [JSNode]
449+ prelude =
450+ [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version)
451+ , WhiteSpace tokenPosnEmpty "\n"
452+ ])
453+ [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace))
454+ [ sp (JSLiteral "=")
455+ , NN (JSObjectLiteral (sp (JSLiteral "{"))
456+ []
457+ (sp (JSLiteral "}")))
458+ ])
459+ ]
460+ (nt (JSLiteral ";")))
461+ , lf
462+ ]
463+
464+ moduleReference :: (Node -> JSNode) -> String -> JSNode
465+ moduleReference f mn =
466+ NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ]
467+ (nt (JSLiteral "["))
468+ (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
469+ (nt (JSLiteral "]")))
470+
471+ wrap :: String -> [JSNode] -> [JSNode]
472+ wrap mn ds =
473+ [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "("))
474+ (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function"))
475+ []
476+ (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")"))
477+ (NN (JSBlock [sp (JSLiteral "{")]
478+ (lf : ds)
479+ [nl (JSLiteral "}")])))]))
480+ (nt (JSLiteral ")")))
481+ , NN (JSArguments (nt (JSLiteral "("))
482+ [ NN (JSExpression [ moduleReference nt mn
483+ , NN (JSOperator (sp (JSLiteral "=")))
484+ , NN (JSExpressionBinary "||"
485+ [ moduleReference sp mn ]
486+ (sp (JSLiteral "||"))
487+ [ emptyObj ])
488+ ])
489+ ]
490+ (nt (JSLiteral ")")))
491+ ])
492+ , nt (JSLiteral ";")
493+ , lf
494+ ]
495+ where
496+ emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}")))
497+
498+ runMain :: String -> [JSNode]
499+ runMain mn =
500+ [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ]
501+ (nt (JSLiteral "["))
502+ (NN (JSExpression [ nt (JSStringLiteral '"' mn) ]))
503+ (nt (JSLiteral "]")))
504+ ]
505+ (nt (JSLiteral "."))
506+ (nt (JSIdentifier "main")))
507+ , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")")))
508+ ])
509+ , nt (JSLiteral ";")
510+ ]
511+
512+ nt :: Node -> JSNode
513+ nt n = NT n tokenPosnEmpty []
514+
515+ lf :: JSNode
516+ lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
517+
518+ sp :: Node -> JSNode
519+ sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ]
520+
521+ nl :: Node -> JSNode
522+ nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ]
523+
524+-- | The bundling function.
525+-- This function performs dead code elimination, filters empty modules
526+-- and generates and prints the final Javascript bundle.
527+bundle :: forall m. (Applicative m, MonadError ErrorMessage m)
528+ => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@.
529+ -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination
530+ -> Maybe String -- ^ An optional main module.
531+ -> String -- ^ The namespace (e.g. PS).
532+ -> m String
533+bundle inputStrs entryPoints mainModule namespace = do
534+ input <- forM inputStrs $ \(ident, js) -> do
535+ ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident)
536+ return (ident, ast)
537+
538+ let mids = S.fromList (map (moduleName . fst) input)
539+
540+ modules <- mapM (fmap withDeps . uncurry (toModule mids)) input
541+
542+ let compiled = compile modules entryPoints
543+ sorted = sortModules (filter (not . isModuleEmpty) compiled)
544+
545+ return (codeGen mainModule namespace sorted)