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